1 C*********************************************************************
2 C*********************************************************************
6 C* The Lund Monte Carlo **
8 C* PYTHIA version 6.4 **
10 C* Torbjorn Sjostrand **
11 C* CERN/PH, CH-1211 Geneva, Switzerland **
12 C* phone +41 - 22 - 767 82 27 **
14 C* Department of Theoretical Physics **
16 C* Solvegatan 14A, S-223 62 Lund, Sweden **
17 C* E-mail torbjorn@thep.lu.se **
19 C* SUSY and Technicolor parts by **
21 C* Computing Division **
22 C* Generators and Detector Simulation Group **
23 C* Fermi National Accelerator Laboratory **
24 C* MS 234, Batavia, IL 60510, USA **
25 C* phone + 1 - 630 - 840 - 2556 **
26 C* E-mail mrenna@fnal.gov **
28 C* New multiple interactions and more SUSY parts by **
30 C* Theoretical Physics Department **
31 C* Fermi National Accelerator Laboratory **
32 C* MS 106, Batavia, IL 60510, USA **
33 C* phone + 1 - 630 - 840 - 2270 **
34 C* E-mail skands@fnal.gov **
36 C* Several parts are written by Hans-Uno Bengtsson **
37 C* PYSHOW is written together with Mats Bengtsson **
38 C* PYMAEL is written by Emanuel Norrbin **
39 C* advanced popcorn baryon production written by Patrik Eden **
40 C* code for virtual photons mainly written by Christer Friberg **
41 C* code for low-mass strings mainly written by Emanuel Norrbin **
42 C* Bose-Einstein code mainly written by Leif Lonnblad **
43 C* CTEQ parton distributions are by the CTEQ collaboration **
44 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
45 C* SaS photon parton distributions together with Gerhard Schuler **
46 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
47 C* MSSM Higgs mass calculation code by M. Carena, **
48 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
49 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50 C* NRQCD/colour octet production of onium by S. Wolf **
52 C* The latest program version and documentation is found on WWW **
53 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
55 C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
57 C*********************************************************************
58 C*********************************************************************
60 C List of subprograms in order of appearance, with main purpose *
61 C (S = subroutine, F = function, B = block data) *
63 C B PYDATA to contain all default values *
64 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65 C S PYTEST to test the proper functioning of the package *
66 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
68 C S PYINIT to administer the initialization procedure *
69 C S PYEVNT to administer the generation of an event *
70 C S PYEVNW ditto, for new multiple interactions scenario *
71 C S PYSTAT to print cross-section and other information *
72 C S PYUPEV to administer the generation of an LHA hard process *
73 C S PYUPIN to provide initialization needed for LHA input *
74 C S PYLHEF to produce a Les Houches Event File from run *
75 C S PYINRE to initialize treatment of resonances *
76 C S PYINBM to read in beam, target and frame choices *
77 C S PYINKI to initialize kinematics of incoming particles *
78 C S PYINPR to set up the selection of included processes *
79 C S PYXTOT to give total, elastic and diffractive cross-sect. *
80 C S PYMAXI to find differential cross-section maxima *
81 C S PYPILE to select multiplicity of pileup events *
82 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83 C S PYGAGA to handle lepton -> lepton + gamma branchings *
84 C S PYRAND to select subprocess and kinematics for event *
85 C S PYSCAT to set up kinematics and colour flow of event *
86 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87 C S PYSSPA to simulate initial state spacelike showers *
88 C S PYPTIS to do pT-ordered initial state spacelike showers *
89 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91 C S PYPTMI to do pT-ordered multiple interactions *
92 C F PYFCMP to give companion quark x*f distribution *
93 C F PYPCMP to calculate momentum integral for companion quarks *
94 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95 C S PYADSH to administrate sequential final-state showers *
96 C S PYVETO to allow the generation of an event to be aborted *
97 C S PYRESD to perform resonance decays *
98 C S PYMULT to generate multiple interactions - old scheme *
99 C S PYREMN to add on target remnants - old scheme *
100 C S PYMIGN to generate multiple interactions - new scheme *
101 C S PYMIHK to connect colours in mult. int. - new scheme *
102 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104 C S PYMIRM to add on target remnants in mult. int.- new scheme *
105 C S PYFSCR to perform final state colour reconnections - -"- *
106 C S PYDIFF to set up kinematics for diffractive events *
107 C S PYDISG to set up kinematics, remnant and showers for DIS *
108 C S PYDOCU to compute cross-sections and handle documentation *
109 C S PYFRAM to perform boosts between different frames *
110 C S PYWIDT to calculate full and partial widths of resonances *
111 C S PYOFSH to calculate partial width into off-shell channels *
112 C S PYRECO to handle colour reconnection in W+W- events *
113 C S PYKLIM to calculate borders of allowed kinematical region *
114 C S PYKMAP to construct value of kinematical variable *
115 C S PYSIGH to calculate differential cross-sections *
116 C S PYSGQC auxiliary to PYSIGH for QCD processes *
117 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123 C S PYPDFU to evaluate parton distributions *
124 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125 C S PYPDEL to evaluate electron parton distributions *
126 C S PYPDGA to evaluate photon parton distributions (generic) *
127 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128 C S PYGVMD to evaluate VMD part of photon parton distributions *
129 C S PYGANO to evaluate anomalous part of photon PDFs *
130 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131 C S PYGDIR to evaluate direct contribution to photon PDFs *
132 C S PYPDPI to evaluate pion parton distributions *
133 C S PYPDPR to evaluate proton parton distributions *
134 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138 C F PYGRVV auxiliary to the PYGRV* routines *
139 C F PYGRVW auxiliary to the PYGRV* routines *
140 C F PYGRVS auxiliary to the PYGRV* routines *
141 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143 C S PYPDPO to evaluate old proton parton distributions *
144 C F PYHFTH to evaluate threshold factor for heavy flavour *
145 C S PYSPLI to find flavours left in hadron when one removed *
146 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151 C S PYSTBH to evaluate matrix element for t + b + H processes *
152 C S PYTBHB auxiliary to PYSTBH *
153 C S PYTBHG auxiliary to PYSTBH *
154 C S PYTBHQ auxiliary to PYSTBH *
155 C F PYTBHS auxiliary to PYSTBH *
157 C S PYMSIN to initialize the supersymmetry simulation *
158 C S PYSLHA to interface to SUSY spectrum and decay calculators *
159 C S PYAPPS to determine MSSM parameters from SUGRA input *
160 C S PYSUGI to determine MSSM parameters using ISASUSY *
161 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162 C F PYRNMQ to determine running squark masses *
163 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164 C S PYINOM to calculate neutralino/chargino mass eigenstates *
165 C F PYRNM3 to determine running M3, gluino mass *
166 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167 C S PYHGGM to determine Higgs mass spectrum *
168 C S PYSUBH to determine Higgs masses in the MSSM *
169 C S PYPOLE to determine Higgs masses in the MSSM *
170 C S PYRGHM auxiliary to PYPOLE *
171 C S PYGFXX auxiliary to PYRGHM *
172 C F PYFINT auxiliary to PYPOLE *
173 C F PYFISB auxiliary to PYFINT *
174 C S PYSFDC to calculate sfermion decay partial widths *
175 C S PYGLUI to calculate gluino decay partial widths *
176 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177 C S PYTBBC to calculate 3-body decay of gluino to chargino *
178 C S PYNJDC to calculate neutralino decay partial widths *
179 C S PYCJDC to calculate chargino decay partial widths *
180 C F PYXXZ6 auxiliary for ino 3-body decays *
181 C F PYXXGA auxiliary for ino -> ino + gamma decay *
182 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184 C S PYHEXT to calculate non-SM Higgs decay partial widths *
185 C F PYH2XX auxiliary for H -> ino + ino decay *
186 C F PYGAUS to perform Gaussian integration *
187 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188 C F PYSIMP to perform Simpson integration *
189 C F PYLAMF to evaluate the lambda kinematics function *
190 C S PYTBDY to perform 3-body decay of gauginos *
191 C S PYTECM to calculate techni_rho/omega masses *
192 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
193 C S PYCMQR auxiliary to PYEICG *
194 C S PYCMQ2 auxiliary to PYEICG *
195 C S PYCDIV auxiliary to PYCMQR *
196 C S PYCSRT auxiliary to PYCMQR *
197 C S PYTHAG auxiliary to PYCMQR *
198 C S PYCBAL auxiliary to PYEICG *
199 C S PYCBA2 auxiliary to PYEICG *
200 C S PYCRTH auxiliary to PYEICG *
201 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
202 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
203 C S PYWIDX to calculate decay widths from within PYWIDT *
204 C S PYRVSF to calculate R-violating sfermion decay widths *
205 C S PYRVNE to calculate R-violating neutralino decay widths *
206 C S PYRVCH to calculate R-violating chargino decay widths *
207 C S PYRVGL to calculate R-violating gluino decay widths *
208 C F PYRVSB auxiliary to PYRVSF *
209 C S PYRVGW to calculate R-Violating 3-body widths *
210 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
211 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
212 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
213 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
214 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
215 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
216 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
217 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
218 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
220 C S PY1ENT to fill one entry (= parton or particle) *
221 C S PY2ENT to fill two entries *
222 C S PY3ENT to fill three entries *
223 C S PY4ENT to fill four entries *
224 C S PY2FRM to interface to generic two-fermion generator *
225 C S PY4FRM to interface to generic four-fermion generator *
226 C S PY6FRM to interface to generic six-fermion generator *
227 C S PY4JET to generate a shower from a given 4-parton config *
228 C S PY4JTW to evaluate the weight od a shower history for above *
229 C S PY4JTS to set up the parton configuration for above *
230 C S PYJOIN to connect entries with colour flow information *
231 C S PYGIVE to fill (or query) commonblock variables *
232 C S PYONOF to allow easy control of particle decay modes *
233 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
234 C S PYEXEC to administrate fragmentation and decay chain *
235 C S PYPREP to rearrange showered partons along strings *
236 C S PYSTRF to do string fragmentation of jet system *
237 C S PYJURF to find boost to string junction rest frame *
238 C S PYINDF to do independent fragmentation of one or many jets *
239 C S PYDECY to do the decay of a particle *
240 C S PYDCYK to select parton and hadron flavours in decays *
241 C S PYKFDI to select parton and hadron flavours in fragm *
242 C S PYNMES to select number of popcorn mesons *
243 C S PYKFIN to calculate falvour prod. ratios from input params. *
244 C S PYPTDI to select transverse momenta in fragm *
245 C S PYZDIS to select longitudinal scaling variable in fragm *
246 C S PYSHOW to do m-ordered timelike parton shower evolution *
247 C S PYPTFS to do pT-ordered timelike parton shower evolution *
248 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
249 C S PYBOEI to include Bose-Einstein effects (crudely) *
250 C S PYBESQ auxiliary to PYBOEI *
251 C F PYMASS to give the mass of a particle or parton *
252 C F PYMRUN to give the running MSbar mass of a quark *
253 C S PYNAME to give the name of a particle or parton *
254 C F PYCHGE to give three times the electric charge *
255 C F PYCOMP to compress standard KF flavour code to internal KC *
256 C S PYERRM to write error messages and abort faulty run *
257 C F PYALEM to give the alpha_electromagnetic value *
258 C F PYALPS to give the alpha_strong value *
259 C F PYANGL to give the angle from known x and y components *
260 C F PYR to provide a random number generator *
261 C S PYRGET to save the state of the random number generator *
262 C S PYRSET to set the state of the random number generator *
263 C S PYROBO to rotate and/or boost an event *
264 C S PYEDIT to remove unwanted entries from record *
265 C S PYLIST to list event record or particle data *
266 C S PYLOGO to write a logo *
267 C S PYUPDA to update particle data *
268 C F PYK to provide integer-valued event information *
269 C F PYP to provide real-valued event information *
270 C S PYSPHE to perform sphericity analysis *
271 C S PYTHRU to perform thrust analysis *
272 C S PYCLUS to perform three-dimensional cluster analysis *
273 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
274 C S PYJMAS to give high and low jet mass of event *
275 C S PYFOWO to give Fox-Wolfram moments *
276 C S PYTABU to analyze events, with tabular output *
278 C S PYEEVT to administrate the generation of an e+e- event *
279 C S PYXTEE to give the total cross-section at given CM energy *
280 C S PYRADK to generate initial state photon radiation *
281 C S PYXKFL to select flavour of primary qqbar pair *
282 C S PYXJET to select (matrix element) jet multiplicity *
283 C S PYX3JT to select kinematics of three-jet event *
284 C S PYX4JT to select kinematics of four-jet event *
285 C S PYXDIF to select angular orientation of event *
286 C S PYONIA to perform generation of onium decay to gluons *
288 C S PYBOOK to book a histogram *
289 C S PYFILL to fill an entry in a histogram *
290 C S PYFACT to multiply histogram contents by a factor *
291 C S PYOPER to perform operations between histograms *
292 C S PYHIST to print and reset all histograms *
293 C S PYPLOT to print a single histogram *
294 C S PYNULL to reset contents of a single histogram *
295 C S PYDUMP to dump histogram contents onto a file *
297 C S PYKCUT dummy routine for user kinematical cuts *
298 C S PYEVWT dummy routine for weighting events *
299 C S UPINIT dummy routine to initialize user processes *
300 C S UPEVNT dummy routine to generate a user process event *
301 C S UPVETO dummy routine to abort event at parton level *
302 C S PDFSET dummy routine to be removed when using PDFLIB *
303 C S STRUCTM dummy routine to be removed when using PDFLIB *
304 C S STRUCTP dummy routine to be removed when using PDFLIB *
305 C S SUGRA dummy routine to be removed when linking with ISAJET *
306 C F VISAJE dummy functn. to be removed when linking with ISAJET *
307 C S SSMSSM dummy routine to be removed when linking with ISAJET *
308 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
309 C S FHSETPARA dummy routine -"- FEYNHIGGS *
310 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
311 C S PYTAUD dummy routine for interface to tau decay libraries *
312 C S PYTIME dummy routine for giving date and time *
314 C*********************************************************************
317 C...Default values for switches and parameters,
318 C...and particle, decay and process data.
322 C...Double precision and integer declarations.
323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
324 IMPLICIT INTEGER(I-N)
325 INTEGER PYK,PYCHGE,PYCOMP
327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
329 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
330 COMMON/PYDAT4/CHAF(500,2)
332 COMMON/PYDATR/MRPY(6),RRPY(100)
333 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
334 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
335 COMMON/PYINT1/MINT(400),VINT(400)
336 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
337 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
338 COMMON/PYINT4/MWID(500),WIDS(500,5)
339 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
340 COMMON/PYINT6/PROC(0:500)
342 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
343 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
344 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
345 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
346 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
347 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
348 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
349 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
350 & AU(3,3),AD(3,3),AE(3,3)
351 COMMON/PYLH3C/CPRO(2),CVER(2)
352 CHARACTER CPRO*12,CVER*12
353 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
354 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
355 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
356 &/PYBINS/,/PYLH3P/,/PYLH3C/
358 C...PYDAT1, containing status codes and most parameters.
360 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
361 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
362 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
363 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
364 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
365 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
366 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
368 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
369 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
371 DATA (PARU(I),I=1,100)/
372 & 3.141592653589793D0, 6.283185307179586D0,
373 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
374 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
375 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
376 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
377 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
378 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
379 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
381 DATA (PARU(I),I=101,200)/
382 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
383 & 0D0, 0D0, 0D0, 0D0, 0D0,
384 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
385 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
386 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
387 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
388 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
389 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
390 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
391 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
392 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
393 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
395 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
396 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
397 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
398 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
399 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
400 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
402 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
403 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
406 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
407 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
408 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
409 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
410 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
411 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
412 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
413 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
414 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
415 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
416 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
417 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
418 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
419 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
420 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
421 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
422 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
426 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
427 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
428 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
429 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
432 C...PYDAT2, with particle data and flavour treatment parameters.
433 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
434 &-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,
435 &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,
436 &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,
437 &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,
438 &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,
439 &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,
440 &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,
441 &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,
443 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
444 &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,
445 &-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,
446 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
447 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
448 &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,
449 &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,
450 &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/
451 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
452 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
453 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
454 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
455 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
456 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
457 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
458 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
459 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
460 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
461 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
462 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
463 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
464 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
465 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
466 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
467 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
468 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
469 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
470 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
471 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
472 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
473 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
474 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
475 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
476 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
477 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
478 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
479 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
480 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
482 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
483 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
484 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
485 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
486 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
487 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
488 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
489 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
490 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
491 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
492 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
493 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
494 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
495 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
496 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
497 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
498 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
499 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
500 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
501 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
502 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
503 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
504 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
505 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
506 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
507 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
508 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
509 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
510 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
511 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
512 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
513 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
514 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
516 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
517 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
518 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
519 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
520 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
521 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
522 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
523 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
524 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
525 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
526 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
527 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
528 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
529 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
530 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
531 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
532 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
533 &7*0D0,6*0.01D0,133*0D0/
534 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
535 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
536 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
537 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
538 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
539 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
540 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
541 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
542 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
543 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
544 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
545 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
546 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
547 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
548 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
549 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
550 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
551 &8.80013D0,13*0D0,133*0D0/
552 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
553 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
554 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
555 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
556 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
557 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
558 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
559 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,118*0D0,133*0D0/
561 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
562 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
563 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
564 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
565 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
566 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
567 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
568 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
569 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
570 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
571 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
572 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
573 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
575 4 0.2D0, 0.5D0, 8*0D0,
577 DATA ((VCKM(I,J),J=1,4),I=1,4)/
578 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
579 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
580 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
581 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
583 C...PYDAT3, with particle decay parameters and data.
585 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
586 &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,
587 &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,
588 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,6*1,133*0/
589 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
590 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
591 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
592 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
593 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
594 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
595 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
596 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
597 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
598 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
599 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
600 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
601 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
602 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
603 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
604 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
605 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
606 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
607 &3924,0,3960,0,3996,4004,4012,4020,4023,4047,4073,4097,4103,4110,
608 &4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
609 DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,7*0,4285,4286,4287,
610 &4288,4289,4290,133*0/
611 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
612 &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,
613 &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,
614 &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,
615 &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,
616 &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,
617 &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,
618 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
619 &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,
620 &3*22,15,12,2*7,7*0,6*1,133*0/
621 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
622 &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,
623 &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,
624 &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,
625 &1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
626 &5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,117*1,3710*0/
627 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
628 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
629 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
630 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
631 &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,
632 &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,
633 &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,
634 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
635 &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,
636 &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,
637 &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,
638 &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,
639 &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,
640 &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,
641 &46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,17*0,6*51,3710*0/
642 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
643 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
644 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
645 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
646 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
647 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
648 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
649 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
650 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
651 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
652 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
653 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
654 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
655 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
656 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
657 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
658 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
659 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
660 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
661 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
662 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
663 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
664 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
665 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
666 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
667 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
668 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
669 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
670 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
671 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
672 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
673 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
674 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
675 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
676 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
677 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
678 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
679 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
680 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
681 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
682 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
683 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
684 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
685 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
686 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
687 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
688 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
689 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
690 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
691 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
692 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
693 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
694 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
695 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
696 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
697 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
698 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
699 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
700 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
701 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
702 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
703 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
704 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
705 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
706 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
707 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
708 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
709 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
710 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
711 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
712 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
713 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
714 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
715 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
716 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
717 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
718 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
719 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
720 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
721 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
722 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
723 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
724 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
725 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
726 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
727 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
728 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
729 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
730 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
731 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
732 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
733 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
734 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
735 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
736 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
737 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
738 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
739 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
740 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
741 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
742 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
743 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
744 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
745 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
746 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
747 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
748 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
749 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
750 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
751 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
752 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
753 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
754 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
755 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
756 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
757 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
758 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
759 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
760 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
761 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
762 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
763 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
764 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
765 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
766 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
767 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
768 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
769 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
770 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
771 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
772 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
773 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
774 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
775 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
776 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
777 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
778 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
779 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
780 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
781 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
782 DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
783 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
784 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
785 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
786 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
787 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
788 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
789 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
790 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
791 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
792 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
793 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
794 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
795 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
796 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
797 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
798 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
799 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
800 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
801 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
802 DATA (BRAT(I) ,I=4150,4280)/0.021617D0,0.030018D0,0.098466D0,
803 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
804 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
805 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0.19874D0,0.010204D0,
806 &0.000003D0,0.010205D0,0.198356D0,0.000151D0,0.000006D0,
807 &0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,0.010205D0,
808 &0.198356D0,0.000151D0,0.000006D0,0.000367D0,0.081967D0,4*0D0,
809 &0.198776D0,0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,
810 &0.000006D0,0.000367D0,0.081893D0,0.198776D0,0.010206D0,
811 &0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,0.000367D0,
812 &0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
813 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,
814 &0.199344D0,0.010234D0,0.000003D0,0.010236D0,0.198928D0,
815 &0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,0.184738D0,
816 &0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,0.022902D0,
817 &0.008429D0,0.015602D0,0.022902D0,0.008429D0,0.015602D0,
818 &0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,0.000008D0,
819 &0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,0.27911D0,
820 &2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,
821 &0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0/
822 DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
824 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
825 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
826 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
827 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
828 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
829 &-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,
830 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
831 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
832 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
833 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
834 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
835 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
836 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
837 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
838 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
839 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
840 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
841 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
842 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
843 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
844 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
845 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
846 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
847 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
848 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
849 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
850 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
851 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
852 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
853 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
854 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
855 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
856 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
857 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
858 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
859 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
860 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
861 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
862 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
863 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
864 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
865 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
866 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
867 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
868 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
869 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
870 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
871 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
872 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
873 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
874 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
875 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
876 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
877 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
878 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
879 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
880 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
881 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
882 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
883 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
884 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
885 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
886 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
887 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
888 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
889 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
890 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
891 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
892 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
893 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
894 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
895 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
896 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
897 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
898 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
899 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
900 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
901 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
902 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
903 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
904 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
905 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
906 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
907 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
908 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
909 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
910 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
911 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
912 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
913 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
914 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
915 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
916 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
917 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
918 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
919 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
920 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
921 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
922 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
923 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
924 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
925 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
926 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
927 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
928 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
929 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
930 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
931 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
932 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
933 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
934 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
935 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
936 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
937 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
938 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
939 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
940 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
941 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
942 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
943 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
944 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
945 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
946 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
947 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
948 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
949 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
950 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
951 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
952 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
953 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
954 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
955 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
956 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
957 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
958 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
959 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
960 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
961 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
962 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
963 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
964 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
965 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
966 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
967 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
968 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
969 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
970 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
971 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
972 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
973 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
974 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
975 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
976 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
977 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
978 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
979 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
980 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
981 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
982 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
983 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
984 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
985 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
986 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
987 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
988 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
989 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
990 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
991 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
992 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
993 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
994 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
995 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
996 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
997 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
998 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
999 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1000 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1001 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1002 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1003 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1004 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1005 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1006 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1007 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1008 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1009 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1010 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1011 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1012 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1013 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1014 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1015 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1016 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1017 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1018 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1019 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1020 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1021 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1022 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1023 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1024 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1025 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1026 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1027 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1028 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1029 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1030 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1031 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1032 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1033 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1034 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1035 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1036 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1037 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1038 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1039 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1040 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1041 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1042 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1043 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1044 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1045 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1046 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1047 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1048 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1049 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1050 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1051 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1052 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1053 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1054 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1055 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1056 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1057 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1058 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1059 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1060 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1061 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1062 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1063 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1064 DATA (KFDP(I,1),I=3783,4127)/1000039,1000024,1000037,1000022,
1065 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1066 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1067 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1068 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1069 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1070 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1071 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1072 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1073 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1074 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1075 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1076 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1077 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1078 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1079 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1080 &2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1081 &2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
1082 &23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1083 &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/
1084 DATA (KFDP(I,1),I=4128,8000)/5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,
1085 &3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,3,4,
1086 &5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,9*11,9*-11,2*11,
1087 &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,
1088 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,
1089 &-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,
1091 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,
1092 &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,
1093 &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,
1094 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1095 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1096 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1097 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1098 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1099 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1100 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1101 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1102 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1103 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1104 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1105 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1106 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1107 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1108 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1109 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1110 &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/
1111 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1112 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1113 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1114 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1115 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1116 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1117 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1118 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1119 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1120 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1121 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1122 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1123 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1124 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1125 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1126 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1127 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1128 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1129 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1130 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1131 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1132 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1133 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1134 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1135 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1136 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1137 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1138 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1139 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1140 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1141 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1142 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1143 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1144 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1145 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1146 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1147 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1148 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1149 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1150 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1151 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1152 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1153 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1154 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1155 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1156 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1157 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1158 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1159 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1160 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1161 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1162 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1163 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1164 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1165 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1166 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1167 &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,
1168 &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,
1169 &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,
1170 &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/
1171 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1172 &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,
1173 &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,
1174 &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,
1175 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1176 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1177 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1178 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1179 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1180 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1181 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1182 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1183 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1184 &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,
1185 &-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,
1186 &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,
1187 &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,
1188 &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,
1189 &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,
1190 &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/
1191 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1192 &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,
1193 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1194 &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,
1195 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1196 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1197 &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,
1198 &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,
1199 &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,
1200 &-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,
1201 &-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,
1202 &-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,
1203 &-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,
1204 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1205 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1206 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1207 &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,
1208 &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,
1209 &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,
1210 &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/
1211 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1212 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1213 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1214 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1215 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1216 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1217 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1218 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1219 &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,
1220 &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,
1221 &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,
1222 &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,
1223 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1224 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1225 &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,
1226 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1227 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1228 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1229 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1230 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1231 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1232 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1233 &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,
1234 &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,
1235 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1236 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1237 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1238 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1239 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1240 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1241 &-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,
1242 &-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,
1243 &-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,
1244 &-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,
1245 &-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,
1246 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1247 &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,
1248 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1249 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1250 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1251 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1252 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1253 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1254 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1255 &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,
1256 &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,
1257 &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,
1258 &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,
1259 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1260 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1261 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1262 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1263 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1264 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1265 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1266 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1267 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1268 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1269 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1270 &-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/
1271 DATA (KFDP(I,2),I=3670,4136)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1272 &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,
1273 &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,
1274 &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,
1275 &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,
1276 &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,
1277 &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,
1278 &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,
1279 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1280 &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,
1281 &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,
1282 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1283 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1284 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-24,-3000211,-24,-3000211,
1285 &3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
1286 &-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,2,4,6,8,
1287 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,
1288 &2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1289 &-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,
1290 &21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,-1/
1291 DATA (KFDP(I,2),I=4137,8000)/-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1292 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1293 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1294 &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,
1295 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1296 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1297 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,6*21,3710*0/
1298 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1299 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1300 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1301 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1302 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1303 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1304 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1305 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1306 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1307 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1308 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1309 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1310 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1311 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1312 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1313 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1314 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1315 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1316 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1317 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1318 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1319 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1320 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1321 &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,
1322 &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,
1323 &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,
1324 &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,
1325 &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,
1326 &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,
1327 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1328 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1329 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1330 &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,
1331 &-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,
1332 &-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,
1333 &-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,
1334 &-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,
1335 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1336 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1337 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1338 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1339 &-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,
1340 &-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,
1341 &-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,
1342 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1343 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1344 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1345 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1346 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1347 &-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,
1348 &-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,
1349 &-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,
1350 &-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,
1351 &-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,
1352 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1353 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1354 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1355 &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,
1356 &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,
1357 &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/
1358 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1359 &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,
1360 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1361 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1362 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1363 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1364 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1365 &-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,
1366 &-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,
1367 &-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,
1368 &-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,
1369 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1370 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1371 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1372 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1373 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1374 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1375 &-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,
1376 &-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,
1377 &-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/
1378 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1379 &-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,
1380 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1381 &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,
1382 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1383 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1384 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1385 &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,
1386 &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,
1387 &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,
1388 &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,
1389 &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,
1390 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,
1391 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,
1392 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3757*0/
1393 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1394 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1395 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1396 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1397 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1398 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1399 &-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,
1400 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1401 &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,
1402 &162*81,31*0,-211,111,6516*0/
1403 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1404 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1405 &3*111,-211,111,7193*0/
1407 C...PYDAT4, with particle names (character strings).
1409 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1410 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1411 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1412 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1413 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1414 &'junction',' ','system','cluster','string','indep.','CMshower',
1415 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1416 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1417 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1418 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1419 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1420 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1421 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1422 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1423 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1424 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1425 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1426 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1427 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1428 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1429 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1430 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1431 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1432 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1433 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1434 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1435 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1436 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1437 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1438 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1439 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1440 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1441 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1442 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1443 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1444 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1445 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1446 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1447 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1448 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1449 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1450 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1451 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1452 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1453 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1454 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1455 &'bb~[3S18]','bb~[1S08]','bb~[3P08]',133*' '/
1456 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1457 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1458 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1459 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1460 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1461 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1462 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1463 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1464 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1465 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1466 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1467 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1468 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1469 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1470 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1471 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1472 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1473 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1474 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1475 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1476 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1477 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1478 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1479 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1480 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1481 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1482 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1483 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1484 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1485 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1486 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1487 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1488 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1489 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1490 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1491 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1492 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1493 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1494 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1495 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1496 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1497 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1498 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1499 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1501 C...PYDATR, with initial values for the random number generator.
1502 DATA MRPY/19780503,0,0,97,33,0/
1504 C...Default values for allowed processes and kinematics constraints.
1507 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1508 &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,
1511 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1512 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1513 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1514 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1515 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1516 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1517 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1518 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1519 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1520 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1521 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1522 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1523 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1524 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1525 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1526 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1529 C...Default values for main switches and parameters. Reset information.
1530 DATA (MSTP(I),I=1,100)/
1531 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1532 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1533 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1534 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1535 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1536 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1537 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1538 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1539 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1540 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1541 DATA (MSTP(I),I=101,200)/
1542 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1543 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1544 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1545 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1546 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1547 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1548 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1549 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1550 8 6, 411, 2007, 03, 30, 0, 0, 0, 0, 0,
1551 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1552 DATA (PARP(I),I=1,100)/
1553 & 0.25D0, 10D0, 8*0D0,
1554 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1556 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1557 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1559 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1560 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1561 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1562 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
1563 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1564 DATA (PARP(I),I=101,200)/
1565 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1566 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1567 2 1.0D0, 0.4D0, 8*0D0,
1569 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1570 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1571 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1572 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1573 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1574 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1576 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1582 C...Constants for the generation of the various processes.
1583 DATA (ISET(I),I=1,100)/
1584 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1585 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1586 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1587 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1588 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1589 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1590 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1591 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1592 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1593 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1594 DATA (ISET(I),I=101,200)/
1595 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1596 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1597 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1598 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1599 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1600 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1601 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1602 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1603 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1604 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1605 DATA (ISET(I),I=201,300)/
1606 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1607 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1608 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1609 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1610 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1611 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1612 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1613 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1614 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1615 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1616 DATA (ISET(I),I=301,500)/
1618 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1619 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1620 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1621 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1622 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1623 9 1, 1, 2, 2, 2, 5*-2,
1625 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1626 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1627 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1628 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1629 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1630 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1631 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1632 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1633 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1634 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1635 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1636 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1637 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1638 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1639 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1640 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1641 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1642 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1643 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1644 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1645 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1646 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1647 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1648 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1649 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1650 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1651 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1652 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1653 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1654 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1655 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1656 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1657 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1658 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1659 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1660 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1661 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1662 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1663 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1664 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1665 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1666 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1667 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1668 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1669 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1670 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1671 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1672 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1673 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1674 & 1000011, 1000011, 2000011, 2000011, 1000011,
1675 & 2000011, 1000013, 1000013, 2000013, 2000013,
1676 & 1000013, 2000013, 1000015, 1000015, 2000015,
1677 & 2000015, 1000015, 2000015, 1000011, 1000012,
1678 1 1000015, 1000016, 2000015, 1000016, 1000012,
1679 1 1000012, 1000016, 1000016, 0, 0,
1680 1 1000022, 1000022, 1000023, 1000023, 1000025,
1681 1 1000025, 1000035, 1000035, 1000022, 1000023,
1682 2 1000022, 1000025, 1000022, 1000035, 1000023,
1683 2 1000025, 1000023, 1000035, 1000025, 1000035,
1684 2 1000024, 1000024, 1000037, 1000037, 1000024,
1685 2 1000037, 1000022, 1000024, 1000023, 1000024,
1686 3 1000025, 1000024, 1000035, 1000024, 1000022,
1687 3 1000037, 1000023, 1000037, 1000025, 1000037,
1688 3 1000035, 1000037, 1000021, 1000022, 1000021,
1689 3 1000023, 1000021, 1000025, 1000021, 1000035/
1690 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1691 4 1000021, 1000024, 1000021, 1000037, 1000021,
1692 4 1000021, 1000021, 1000021, 0, 0,
1693 4 1000002, 1000022, 2000002, 1000022, 1000002,
1694 4 1000023, 2000002, 1000023, 1000002, 1000025,
1695 5 2000002, 1000025, 1000002, 1000035, 2000002,
1696 5 1000035, 1000001, 1000024, 2000005, 1000024,
1697 5 1000001, 1000037, 2000005, 1000037, 1000002,
1698 5 1000021, 2000002, 1000021, 0, 0,
1699 6 1000006, 1000006, 2000006, 2000006, 1000006,
1700 6 2000006, 1000006, 1000006, 2000006, 2000006,
1703 7 1000002, 1000002, 2000002, 2000002, 1000002,
1704 7 2000002, 1000002, 1000002, 2000002, 2000002,
1705 7 1000002, 2000002, 1000002, 1000002, 2000002,
1706 7 2000002, 1000002, 1000002, 2000002, 2000002/
1707 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1708 8 1000005, 1000002, 2000005, 2000002, 1000005,
1709 8 2000002, 1000005, 1000002, 2000005, 2000002,
1710 8 1000005, 2000002, 1000005, 1000005, 2000005,
1711 8 2000005, 1000005, 1000005, 2000005, 2000005,
1712 9 1000005, 1000005, 2000005, 2000005, 1000005,
1713 9 2000005, 1000005, 1000021, 2000005, 1000021,
1714 9 1000005, 2000005, 37, 25, 37,
1715 9 35, 36, 25, 36, 35,
1717 4 9900041, 0, 9900042, 0, 9900041,
1718 4 11, 9900042, 11, 9900041, 13,
1719 4 9900042, 13, 9900041, 15, 9900042,
1720 4 15, 9900041, 9900041, 9900042, 9900042/
1721 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1722 5 9900041, 0, 9900042, 0, 9900023,
1723 5 0, 9900024, 0, 0, 0,
1726 6 24, 24, 24, 3000211, 3000211,
1727 6 3000211, 22, 3000111, 22, 3000221,
1728 6 23, 3000111, 23, 3000221, 24,
1729 6 3000211, 0, 0, 24, 23,
1730 7 24, 3000111, 3000211, 23, 3000211,
1731 7 3000111, 22, 3000211, 23, 3000211,
1732 7 24, 3000111, 24, 3000221, 0,
1734 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1735 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1736 9 5000039, 0, 5000039, 0, 21,
1737 9 5000039, 0, 5000039, 21, 5000039,
1739 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1740 & 37, 6, 37, 6, 36*0,
1741 2 443, 21, 9900443, 21, 9900441,
1742 2 21, 9910441, 21, 0, 9900443,
1743 2 0, 9900441, 0, 9910441, 21,
1744 2 9900443, 21, 9900441, 21, 9910441,
1745 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1746 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1747 6 553, 21, 9900553, 21, 9900551,
1748 6 21, 9910551, 21, 0, 9900553,
1749 6 0, 9900551, 0, 9910551, 21,
1750 6 9900553, 21, 9900551, 21, 9910551,
1751 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1752 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1753 DATA COEF/10000*0D0/
1754 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1755 &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,
1756 &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,
1757 &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,
1758 &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,
1759 &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,
1760 &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,
1761 &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,
1762 &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,
1763 &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,
1764 &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/
1766 C...Treatment of resonances.
1767 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1768 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,133*0/
1770 C...Character constants: name of processes.
1771 DATA PROC(0)/ 'All included subprocesses '/
1772 DATA (PROC(I),I=1,20)/
1773 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1774 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1775 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1776 &' ', 'W+ + W- -> h0 ',
1777 &' ', 'f + f'' -> f + f'' (QFD) ',
1778 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1779 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1780 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1781 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1782 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1783 DATA (PROC(I),I=21,40)/
1784 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1785 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1786 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1787 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1788 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1789 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1790 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1791 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1792 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1793 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1794 DATA (PROC(I),I=41,60)/
1795 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1796 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1797 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1798 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1799 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1800 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1801 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1802 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1803 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1804 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1805 DATA (PROC(I),I=61,80)/
1806 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1807 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1808 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1809 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1810 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1811 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1812 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1813 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1814 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1815 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1816 DATA (PROC(I),I=81,100)/
1817 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1818 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1819 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1820 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1821 8'g + g -> chi_2c + g ', ' ',
1822 9'Elastic scattering ', 'Single diffractive (XB) ',
1823 9'Single diffractive (AX) ', 'Double diffractive ',
1824 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1826 9'q + gamma* -> q ', ' '/
1827 DATA (PROC(I),I=101,120)/
1828 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1829 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1830 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1831 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1832 &' ', 'f + fbar -> gamma + h0 ',
1833 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1834 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1835 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1836 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1838 DATA (PROC(I),I=121,140)/
1839 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1840 2'f + f'' -> f + f'' + h0 ',
1841 2'f + f'' -> f" + f"'' + h0 ',
1845 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1846 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1847 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1848 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1849 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1850 DATA (PROC(I),I=141,160)/
1851 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1852 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1853 4'q + l -> LQ ', 'e + gamma -> e* ',
1854 4'd + g -> d* ', 'u + g -> u* ',
1855 4'g + g -> eta_tc ', ' ',
1856 5'f + fbar -> H0 ', 'g + g -> H0 ',
1857 5'gamma + gamma -> H0 ', ' ',
1858 5' ', 'f + fbar -> A0 ',
1859 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1861 DATA (PROC(I),I=161,180)/
1862 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1863 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1864 6'f + fbar -> f'' + fbar'' (g/Z)',
1865 6'f +fbar'' -> f" + fbar"'' (W) ',
1866 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1867 6'q + qbar -> e + e* ', ' ',
1868 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1869 7'f + f'' -> f + f'' + H0 ',
1870 7'f + f'' -> f" + f"'' + H0 ',
1871 7' ', 'f + fbar -> Z0 + A0 ',
1872 7'f + fbar'' -> W+/- + A0 ',
1873 7'f + f'' -> f + f'' + A0 ',
1874 7'f + f'' -> f" + f"'' + A0 ',
1876 DATA (PROC(I),I=181,200)/
1877 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1878 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1879 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1880 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1881 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1882 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1883 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1884 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1887 DATA (PROC(I),I=201,220)/
1888 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1889 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1890 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1891 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1892 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1893 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1894 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1895 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1896 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1897 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1898 DATA (PROC(I),I=221,240)/
1899 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1900 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1901 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1902 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1903 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1904 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1905 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1906 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1907 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1908 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1909 DATA (PROC(I),I=241,260)/
1910 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1911 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1912 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1913 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1914 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1915 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1916 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1917 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1918 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1919 5'qj + g -> ~qj_R + ~g ', ' '/
1920 DATA (PROC(I),I=261,300)/
1921 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1922 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1923 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1926 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1927 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1928 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1929 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1930 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1931 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1932 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1933 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1934 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1935 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1936 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1937 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1938 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1939 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1940 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1941 DATA (PROC(I),I=301,340)/
1942 &'f + fbar -> H+ + H- ', 39*' '/
1943 DATA (PROC(I),I=341,380)/
1944 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1945 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1946 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1947 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1948 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1949 5'f + f -> f'' + f'' + H_L++/-- ',
1950 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1951 5'f + fbar'' -> W_R+/- ',5*' ',
1952 6' ', 'f + fbar -> W_L+ W_L- ',
1953 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1954 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1955 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1956 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1957 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1958 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1959 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1960 7'f + fbar'' -> W+/- pi_T0 ',
1961 7'f + fbar'' -> W+/- pi_T0'' ',
1964 DATA (PROC(I),I=381,420)/
1965 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1966 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1967 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1968 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1970 9'f + fbar -> G* ', 'g + g -> G* ',
1971 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1972 9'g + g -> g + G* ', ' ',
1974 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
1976 DATA (PROC(I),I=421,460)/
1977 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
1978 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
1979 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
1980 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
1981 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
1982 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
1983 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
1984 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
1985 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
1986 3'q + q~ -> g + cc~[3P2(1)] ',
1988 DATA (PROC(I),I=461,500)/
1989 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
1990 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
1991 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
1992 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
1993 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
1994 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
1995 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
1996 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
1997 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
1998 7'q + q~ -> g + bb~[3P2(1)] ',
2001 C...Cross sections and slope offsets.
2004 C...Supersymmetry switches and parameters.
2006 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2009 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2010 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2011 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2015 C...Initial values for R-violating SUSY couplings.
2016 C...Should not be changed here. See PYMSIN.
2021 C...Technicolor switches and parameters
2023 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2026 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2027 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2028 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2029 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2030 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 4*0D0,
2033 C...Data for histogramming routines.
2034 DATA IHIST/1000,20000,55,1/
2037 C...Data for SUSY Les Houches Accord.
2038 DATA CPRO/'PYTHIA ','PYTHIA '/
2039 DATA CVER/'6.4 ','6.4 '/
2041 DATA PARMIN/100*0D0/
2042 DATA RMSOFT/101*0D0/
2049 C*********************************************************************
2052 C...Check that BLOCK DATA PYDATA has been loaded.
2053 C...Should not be required, except that some compilers/linkers
2054 C...are pretty buggy in this respect.
2058 C...Double precision and integer declarations.
2059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2060 IMPLICIT INTEGER(I-N)
2061 INTEGER PYK,PYCHGE,PYCOMP
2063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2066 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2067 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2068 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2069 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2071 C...Check a few variables to see they have been sensibly initialized.
2072 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2073 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2075 C...If not, abort the run right away.
2076 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2077 WRITE(*,*) 'The program execution is stopped now!'
2084 C*********************************************************************
2087 C...A simple program (disguised as subroutine) to run at installation
2088 C...as a check that the program works as intended.
2090 SUBROUTINE PYTEST(MTEST)
2092 C...Double precision and integer declarations.
2093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2094 IMPLICIT INTEGER(I-N)
2095 INTEGER PYK,PYCHGE,PYCOMP
2097 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2098 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2099 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2100 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2101 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2102 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2103 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2105 DIMENSION PSUM(5),PINI(6),PFIN(6)
2107 C...Save defaults for values that are changed.
2124 C...First part: loop over simple events to be generated.
2125 IF(MTEST.GE.1) CALL PYTABU(20)
2129 C...Reset parameter values. Switch on some nonstandard features.
2144 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2146 C...Ten events each for some single jets configurations.
2150 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2151 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2152 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2153 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2154 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2155 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2157 C...Ten events each for some simple jet systems; string fragmentation.
2158 ELSEIF(IEV.LE.130) THEN
2160 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2161 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2162 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2163 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2164 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2165 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2166 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2167 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2168 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2170 C...Seventy events with independent fragmentation and momentum cons.
2171 ELSEIF(IEV.LE.200) THEN
2173 MSTJ(2)=1+MOD(IEV-131,4)
2174 MSTJ(3)=1+MOD((IEV-131)/4,4)
2175 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2176 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2177 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2178 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2179 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2180 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2182 C...A hundred events with random jets (check invariant mass).
2183 ELSEIF(IEV.LE.300) THEN
2190 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2191 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2192 EJET=5D0+20D0*PYR(0)
2193 THETA=ACOS(2D0*PYR(0)-1D0)
2195 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2196 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2197 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2198 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2200 PSUM(J)=PSUM(J)+P(I,J)
2203 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2204 & (PSUM(5)+PARJ(32))**2) GOTO 100
2206 C...Fifty e+e- continuum events with matrix elements.
2207 ELSEIF(IEV.LE.350) THEN
2211 C...Fifty e+e- continuum event with varying shower options.
2212 ELSEIF(IEV.LE.400) THEN
2213 MSTJ(42)=1+MOD(IEV,2)
2214 MSTJ(43)=1+MOD(IEV/2,4)
2215 MSTJ(44)=MOD(IEV/8,3)
2218 C...Fifty e+e- continuum events with coherent shower.
2219 ELSEIF(IEV.LE.450) THEN
2220 CALL PYEEVT(0,500D0)
2222 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2224 CALL PYONIA(5,9.46D0)
2227 C...Generate event. Find total momentum, energy and charge.
2238 C...Check conservation of energy, momentum and charge;
2239 C...usually exact, but only approximate for single jets.
2242 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2244 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2245 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2246 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2249 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2251 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2253 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2254 & (PFIN(J),J=1,4),PFIN(6)
2256 C...Check that all KF codes are known ones, and that partons/particles
2257 C...satisfy energy-momentum-mass relation. Store particle statistics.
2259 IF(K(I,1).GT.20) GOTO 170
2260 IF(PYCOMP(K(I,2)).EQ.0) THEN
2261 WRITE(MSTU(11),5100) I
2264 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2265 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2267 WRITE(MSTU(11),5200) I
2271 IF(MTEST.GE.1) CALL PYTABU(21)
2273 C...List all erroneous events and some normal ones.
2274 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2275 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2277 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2281 C...Stop execution if too many errors.
2282 IF(MERR.NE.0) NERR=NERR+1
2284 WRITE(MSTU(11),6300)
2290 C...Summarize result of run.
2291 IF(MTEST.GE.1) CALL PYTABU(22)
2293 C...Reset commonblock variables changed during run.
2310 C...Second part: complete events of various kinds.
2311 C...Common initial values. Loop over initiating conditions.
2312 MSTP(122)=MAX(0,MIN(2,MTEST))
2313 MDCY(PYCOMP(111),1)=0
2316 C...Reset process type, kinematics cuts, and the flags used.
2333 C...Prompt photon production at fixed target.
2336 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2340 CALL PYINIT('FIXT','pi+','p',PZSUM)
2342 C...QCD processes at ISR energies.
2343 ELSEIF(IPROC.EQ.2) THEN
2349 CALL PYINIT('CMS','p','p',PESUM)
2351 C...W production + multiple interactions at CERN Collider.
2352 ELSEIF(IPROC.EQ.3) THEN
2361 CALL PYINIT('CMS','p','pbar',PESUM)
2363 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2364 ELSEIF(IPROC.EQ.4) THEN
2376 CALL PYINIT('CMS','p','pbar',PESUM)
2378 C...Higgs production at LHC.
2379 ELSEIF(IPROC.EQ.5) THEN
2391 CALL PYINIT('CMS','p','p',PESUM)
2393 C...Z' production at SSC.
2394 ELSEIF(IPROC.EQ.6) THEN
2403 CALL PYINIT('CMS','p','p',PESUM)
2405 C...W pair production at 1 TeV e+e- collider.
2406 ELSEIF(IPROC.EQ.7) THEN
2413 CALL PYINIT('CMS','e+','e-',PESUM)
2415 C...Deep inelastic scattering at a LEP+LHC ep collider.
2416 ELSEIF(IPROC.EQ.8) THEN
2429 CALL PYINIT('3MOM','p','e-',PESUM)
2432 C...Generate 20 events of each required type.
2436 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2438 C...Check conservation of energy/momentum/flavour.
2449 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2450 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2451 DEVQ=ABS(PFIN(6)-PINI(6))
2452 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2453 & DEVQ.GT.0.1D0) MERR=1
2454 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2455 & (PFIN(J),J=1,4),PFIN(6)
2457 C...Check that all KF codes are known ones, and that partons/particles
2458 C...satisfy energy-momentum-mass relation.
2460 IF(K(I,1).GT.20) GOTO 210
2461 IF(PYCOMP(K(I,2)).EQ.0) THEN
2462 WRITE(MSTU(11),5100) I
2465 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2467 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2468 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2469 WRITE(MSTU(11),5200) I
2474 C...Listing of erroneous events, and first event of each type.
2475 IF(MERR.GE.1) NERR=NERR+1
2477 WRITE(MSTU(11),6300)
2481 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2482 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2487 C...List statistics for each process type.
2488 IF(MTEST.GE.1) CALL PYSTAT(1)
2491 C...Summarize result of run.
2492 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2493 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2495 C...Format statements for output.
2496 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2497 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2498 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2499 &4(1X,F12.5),1X,F8.2)
2500 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2501 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2503 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2504 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2505 6400 FORMAT(5X,'Faulty event follows:')
2506 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2507 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2508 &5X,'This should not have happened!')
2513 C*********************************************************************
2516 C...Converts PYTHIA event record contents to or from
2517 C...the standard event record commonblock.
2519 SUBROUTINE PYHEPC(MCONV)
2521 C...Double precision and integer declarations.
2522 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2523 IMPLICIT INTEGER(I-N)
2524 INTEGER PYK,PYCHGE,PYCOMP
2526 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2529 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2530 C...HEPEVT commonblock.
2531 PARAMETER (NMXHEP=4000)
2532 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2533 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2534 DOUBLE PRECISION PHEP,VHEP
2537 C...Store HEPEVT commonblock size (for interfacing issues).
2540 C...Conversion from PYTHIA to standard, the easy part.
2543 IF(N.GT.NMXHEP) CALL PYERRM(8,
2544 & '(PYHEPC:) no more space in /HEPEVT/')
2548 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2549 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2550 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2551 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2555 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2569 C...Check if new event (from pileup).
2573 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2576 C...Fill in missing mother information.
2577 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2579 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2586 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2589 IF(I1.GE.I) CALL PYERRM(8,
2590 & '(PYHEPC:) translation of inconsistent event history')
2591 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2593 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2594 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2596 ELSEIF(K(I,2).EQ.94) THEN
2598 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2599 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2600 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2601 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2602 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2605 C...Fill in missing daughter information.
2606 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2607 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2608 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2612 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2614 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2615 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2616 IF(JDAHEP(1,I1).EQ.0) THEN
2623 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2624 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2627 C...Conversion from standard to PYTHIA, the easy part.
2629 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2630 & '(PYHEPC:) no more space in /PYJETS/')
2636 IF(ISTHEP(I).EQ.1) K(I,1)=1
2637 IF(ISTHEP(I).EQ.2) K(I,1)=11
2638 IF(ISTHEP(I).EQ.3) K(I,1)=21
2650 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2652 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2653 & PHEP(5,I)/PHEP(4,I)
2656 C...Fill in missing information on colour connection in jet systems.
2657 IF(ISTHEP(I).EQ.1) THEN
2660 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2661 IF(KQ.NE.0) NKQ=NKQ+1
2662 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2663 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2665 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2666 IF(K(I+1,2).EQ.21) K(I,1)=2
2670 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2671 & '(PYHEPC:) input parton configuration not colour singlet')
2676 C*********************************************************************
2679 C...Initializes the generation procedure; finds maxima of the
2680 C...differential cross-sections to be used for weighting.
2682 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2684 C...Double precision and integer declarations.
2685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2686 IMPLICIT INTEGER(I-N)
2687 INTEGER PYK,PYCHGE,PYCOMP
2689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2691 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2692 COMMON/PYDAT4/CHAF(500,2)
2694 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2695 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2696 COMMON/PYINT1/MINT(400),VINT(400)
2697 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2698 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2699 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2700 &/PYINT1/,/PYINT2/,/PYINT5/
2701 C...Local arrays and character variables.
2702 DIMENSION ALAMIN(20),NFIN(20)
2703 CHARACTER*(*) FRAME,BEAM,TARGET
2704 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2706 C...Interface to PDFLIB.
2707 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2708 COMMON/W50512/QCDL4,QCDL5
2709 SAVE /W50511/,/W50512/
2710 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2711 CHARACTER*20 PARM(20)
2712 DATA VALUE/20*0D0/,PARM/20*' '/
2714 C...Data:Lambda and n_f values for parton distributions..
2715 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2716 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2718 DATA CHLH/'lepton','hadron'/
2720 C...Check that BLOCK DATA PYDATA has been loaded.
2723 C...Reset MINT and VINT arrays. Write headers.
2729 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2730 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2732 C...Reset error counters.
2737 C...Reset processes that should not be on.
2741 C...Call user process initialization routine.
2742 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2748 C...Maximum 4 generations; set maximum number of allowed flavours.
2749 MSTP(1)=MIN(4,MSTP(1))
2750 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2751 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2753 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2757 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2760 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2761 IPM=(5-ISIGN(1,I))/2
2763 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2764 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2766 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2771 C...Initialize parton distributions: PDFLIB.
2772 IF(MSTP(52).EQ.2) THEN
2776 VALUE(2)=MSTP(51)/1000
2778 VALUE(3)=MOD(MSTP(51),1000)
2781 CALL PDFSET(PARM,VALUE)
2782 MINT(93)=1000000+MSTP(51)
2785 C...Choose Lambda value to use in alpha-strong.
2787 IF(MSTP(3).GE.2) THEN
2790 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2791 ALAM=ALAMIN(MSTP(51))
2793 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2796 ELSEIF(MSTP(52).EQ.2) THEN
2805 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2808 C...Initialize the SUSY generation: couplings, masses,
2809 C...decay modes, branching ratios, and so on.
2811 C...Initialize widths and partial widths for resonances.
2813 C...Set Z0 mass and width for e+e- routines.
2814 PARJ(123)=PMAS(23,1)
2815 PARJ(124)=PMAS(23,2)
2817 C...Identify beam and target particles and frame of process.
2821 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2822 IF(MINT(65).EQ.1) GOTO 170
2824 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2825 C...For e-gamma allow 2 alternatives.
2827 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2828 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2829 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2830 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2831 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2832 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2833 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2834 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2835 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2836 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2837 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2838 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2839 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2840 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2841 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2842 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2843 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2844 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2847 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2848 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2849 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2850 IF(MSTP(14).EQ.11) MINT(123)=0
2851 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2852 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2853 IF(MSTP(14).EQ.15) MINT(123)=2
2854 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2855 IF(MSTP(14).EQ.19) MINT(123)=3
2856 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2857 IF(MSTP(14).EQ.21) MINT(123)=0
2858 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2859 IF(MSTP(14).EQ.24) MINT(123)=1
2860 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2861 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2862 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2865 C...Set up kinematics of process.
2868 C...Set up kinematics for photons inside leptons.
2869 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2871 C...Precalculate flavour selection weights.
2874 C...Loop over gamma-p or gamma-gamma alternatives.
2877 DO 160 IGA=1,MINT(121)
2881 C...Select partonic subprocesses to be included in the simulation.
2888 C...Count number of subprocesses on.
2891 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2892 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2894 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2895 & MSUB(ISUB).EQ.1) THEN
2896 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2898 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2899 WRITE(MSTU(11),5300) ISUB
2901 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2902 WRITE(MSTU(11),5400) ISUB
2904 ELSEIF(MSUB(ISUB).EQ.1) THEN
2909 C...Stop or raise warning flag if no subprocesses on.
2910 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2911 IF(MSTP(127).NE.1) THEN
2912 WRITE(MSTU(11),5500)
2915 WRITE(MSTU(11),5700)
2919 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2920 MSAV48=MSAV48+MINT(48)
2922 C...Reset variables for cross-section calculation.
2930 C...Find parametrized total cross-sections.
2934 C...Maxima of differential cross-sections.
2935 IF(MSTP(121).LE.1) CALL PYMAXI
2937 C...Initialize possibility of pileup events.
2938 IF(MINT(121).GT.1) MSTP(131)=0
2939 IF(MSTP(131).NE.0) CALL PYPILE(1)
2941 C...Initialize multiple interactions with variable impact parameter.
2942 IF(MINT(50).EQ.1) THEN
2943 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2944 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2945 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2946 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2954 C...Save results for gamma-p and gamma-gamma alternatives.
2955 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2958 C...Initialization finished.
2959 IF(MSAV48.EQ.0) THEN
2960 IF(MSTP(127).NE.1) THEN
2961 WRITE(MSTU(11),5500)
2964 WRITE(MSTU(11),5700)
2968 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2970 C...Formats for initialization information.
2971 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2972 &'routines',1X,17('*'))
2973 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2974 &'-',A6,' interactions.'/1X,'Execution stopped!')
2975 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2976 &1X,'Execution stopped!')
2977 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2978 &1X,'Execution stopped!')
2979 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2980 &1X,'Execution stopped.')
2981 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2983 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2984 &1X,'Execution will stop if you try to generate events.')
2989 C*********************************************************************
2992 C...Administers the generation of a high-pT event via calls to
2993 C...a number of subroutines.
2997 C...Double precision and integer declarations.
2998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2999 IMPLICIT INTEGER(I-N)
3000 INTEGER PYK,PYCHGE,PYCOMP
3002 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3004 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3005 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3007 COMMON/PYINT1/MINT(400),VINT(400)
3008 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3009 COMMON/PYINT4/MWID(500),WIDS(500,5)
3010 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3011 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
3012 &/PYINT2/,/PYINT4/,/PYINT5/
3016 C...Optionally let PYEVNW do the whole job.
3017 IF(MSTP(81).GE.20) THEN
3022 C...Stop if no subprocesses on.
3023 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3024 WRITE(MSTU(11),5100)
3028 C...Initial values for some counters.
3039 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3043 C...Let called routines know call is from PYEVNT (not PYEVNW).
3045 IF (MSTP(81).GE.10) MINT(35)=2
3047 C...If variable energies: redo incoming kinematics and cross-section.
3049 IF(MSTP(171).EQ.1) THEN
3051 IF(MSTI(61).EQ.1) THEN
3055 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3059 C...Loop over number of pileup events; check space left.
3060 IF(MSTP(131).LE.0) THEN
3066 DO 270 IPILE=1,NPILE
3067 IF(MINT(84)+100.GE.MSTU(4)) THEN
3069 & '(PYEVNT:) no more space in PYJETS for pileup events')
3070 IF(MSTU(21).GE.1) GOTO 280
3074 C...Generate variables of hard scattering.
3078 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3084 IF(MSTI(61).EQ.1) THEN
3088 IF(MINT(51).EQ.2) RETURN
3090 IF(MSTP(111).EQ.-1) GOTO 260
3092 C...Loopback point if PYPREP fails, especially for junction topologies.
3098 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3099 C...Hard scattering (including low-pT):
3100 C...reconstruct kinematics and colour flow of hard scattering.
3105 IF(MINT(51).EQ.1) GOTO 100
3108 IF(ISUB.EQ.95) GOTO 140
3110 C...Reset statistics on activity in event.
3116 C...Showering of initial state partons (optional).
3120 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3121 & CALL PYSSPA(IPU1,IPU2)
3123 IF(MINT(51).EQ.1) GOTO 100
3125 C...Showering of final state partons (optional).
3128 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3132 IF(ISET(ISUB).EQ.5) IPU4=-3
3134 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3135 CALL PYSHOW(IPU3,IPU4,QMAX)
3136 ELSEIF(ISET(ISUB).EQ.11) THEN
3141 C...Allow possibility for user to abort event generation.
3143 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3144 IF(IVETO.EQ.1) GOTO 100
3146 C...Decay of final state resonances.
3148 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3149 IF(MINT(51).EQ.1) GOTO 100
3153 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3154 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3155 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3157 IF(MINT(51).EQ.1) GOTO 100
3160 C...Beam remnant flavour and colour assignments - new scheme.
3162 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3164 IF(MINT(51).EQ.1) GOTO 100
3166 C...Primordial kT and beam remnant momentum sharing - new scheme.
3168 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3170 IF(MINT(51).EQ.1) GOTO 100
3171 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3173 C...Multiple interactions - PYTHIA 6.2 style.
3174 ELSEIF(MINT(111).NE.12) THEN
3175 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3180 C...Hadron remnants and primordial kT.
3181 CALL PYREMN(IPU1,IPU2)
3182 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3184 IF(MINT(51).EQ.1) GOTO 100
3187 ELSEIF(ISUB.NE.99) THEN
3188 C...Diffractive and elastic scattering.
3192 C...DIS scattering (photon flux external).
3194 IF(MINT(51).EQ.1) GOTO 100
3197 C...Check that no odd resonance left undecayed.
3199 IF(MSTP(111).GE.1) THEN
3201 DO 150 I=MINT(84)+1,NFIX
3202 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3203 & K(I,2).NE.22) THEN
3205 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3207 IF(MINT(51).EQ.1) GOTO 100
3213 C...Boost hadronic subsystem to overall rest frame.
3214 C..(Only relevant when photon inside lepton beam.)
3215 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3217 C...Recalculate energies from momenta and masses (if desired).
3218 IF(MSTP(113).GE.1) THEN
3219 DO 160 I=MINT(83)+1,N
3220 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3221 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3226 C...Colour reconnection before string formation
3227 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3229 C...Rearrange partons along strings, check invariant mass cuts.
3231 IF(MSTP(111).LE.0) MSTJ(14)=-1
3232 CALL PYPREP(MINT(84)+1)
3234 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3238 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3239 IF (MINT(51).EQ.1) GOTO 100
3240 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3241 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3242 DO 190 I=MINT(84)+1,N
3243 IF(K(I,2).EQ.94) THEN
3244 DO 180 I1=I+1,MIN(N,I+10)
3245 IF(K(I1,3).EQ.I) THEN
3246 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3247 IF(K(I1,3).EQ.0) THEN
3248 DO 170 II=MINT(84)+1,I-1
3249 IF(K(II,2).EQ.K(I1,2)) THEN
3250 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3251 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3254 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3262 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3263 IF(MSTP(125).EQ.0) MINT(4)=0
3264 DO 210 I=MINT(83)+1,N
3265 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3267 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3268 IF(K(I1,3).EQ.I) K(I,5)=I1
3274 C...Introduce separators between sections in PYLIST event listing.
3275 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3278 ELSEIF(IPILE.EQ.1) THEN
3285 C...Go back to lab frame (needed for vertices, also in fragmentation).
3288 C...Set nonvanishing production vertex (optional).
3289 IF(MSTP(151).EQ.1) THEN
3291 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3292 & SIN(PARU(2)*PYR(0))
3294 DO 240 I=MINT(83)+1,N
3296 V(I,J)=V(I,J)+VTX(J)
3301 C...Perform hadronization (if desired).
3302 IF(MSTP(111).GE.1) THEN
3304 IF(MSTU(24).NE.0) GOTO 100
3306 IF(MSTP(113).GE.1) THEN
3308 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3309 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3312 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3314 C...Store event information and calculate Monte Carlo estimates of
3315 C...subprocess cross-sections.
3316 260 IF(IPILE.EQ.1) CALL PYDOCU
3318 C...Set counters for current pileup event and loop to next one.
3320 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3321 IF(MSTU70.LT.10) THEN
3326 MINT(84)=N+MSTP(126)
3327 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3330 C...Generic information on pileup events. Reconstruct missing history.
3331 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3335 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3339 C...Transform to the desired coordinate frame.
3340 280 CALL PYFRAM(MSTP(124))
3345 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3346 &1X,'Execution stopped.')
3351 C*********************************************************************
3354 C...Administers the generation of a high-pT event via calls to
3355 C...a number of subroutines for the new multiple interactions and
3356 C...showering framework.
3360 C...Double precision and integer declarations.
3361 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3362 IMPLICIT INTEGER(I-N)
3363 INTEGER PYK,PYCHGE,PYCOMP
3365 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3366 COMMON/PYCTAG/NCT,MCT(4000,2)
3367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3369 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3370 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3371 COMMON/PYINT1/MINT(400),VINT(400)
3372 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3373 COMMON/PYINT4/MWID(500),WIDS(500,5)
3374 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3375 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3376 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3377 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3378 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3379 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3383 C...Stop if no subprocesses on.
3384 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3385 WRITE(MSTU(11),5100)
3389 C...Initial values for some counters.
3400 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3404 C...Let called routines know call is from PYEVNW (not PYEVNT).
3407 C...If variable energies: redo incoming kinematics and cross-section.
3409 IF(MSTP(171).EQ.1) THEN
3411 IF(MSTI(61).EQ.1) THEN
3415 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3419 C...Loop over number of pileup events; check space left.
3420 IF(MSTP(131).LE.0) THEN
3426 DO 300 IPILE=1,NPILE
3427 IF(MINT(84)+100.GE.MSTU(4)) THEN
3429 & '(PYEVNW:) no more space in PYJETS for pileup events')
3430 IF(MSTU(21).GE.1) GOTO 310
3434 C...Generate variables of hard scattering.
3438 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3445 IF(MSTI(61).EQ.1) THEN
3449 IF(MINT(51).EQ.2) RETURN
3451 IF(MSTP(111).EQ.-1) GOTO 290
3453 C...Loopback point if PYPREP fails, especially for junction topologies.
3459 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3460 C...Hard scattering (including low-pT):
3461 C...reconstruct kinematics and colour flow of hard scattering.
3466 IF(MINT(51).EQ.1) GOTO 100
3470 C...Intertwined initial state showers and multiple interactions.
3471 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3472 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3474 IF (MINT(47).LT.2) MSTP(61)=0
3476 IF (MINT(50).EQ.0) MSTP(81)=0
3477 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3478 & MINT(111).NE.12) THEN
3479 C...Absolute max pT2 scale for evolution: phase space limit.
3480 PT2MXS=0.25D0*VINT(2)
3481 C...Check if more constrained by ISR and MI max scales:
3482 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3483 C...Loopback point in case of failure in evolution.
3487 IF(LOOP.GT.100) THEN
3488 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3489 & //'multiple interactions.')
3494 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3495 C...once per event. (E.g. compute constants and save variables to be
3496 C...restored later in case of failure.)
3497 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3499 C...Initialize interleaved MI/ISR/JI evolution.
3500 C...PT2MAX: absolute upper limit for evolution - Initialization may
3501 C... return a PT2MAX which is lower than this.
3502 C...PT2MIN: absolute lower limit for evolution - Initialization may
3503 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3506 CALL PYEVOL(0,PT2MAX,PT2MIN)
3507 IF (MINT(51).EQ.1) GOTO 130
3509 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3510 C...In principle factorized, so can be stopped and restarted.
3511 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3512 C PT2MED=MAX(10D0**2,PT2MIN)
3513 C CALL PYEVOL(1,PT2MAX,PT2MED)
3514 C IF (MINT(51).EQ.1) GOTO 160
3516 CALL PYEVOL(1,PT2MAX,PT2MIN)
3517 IF (MINT(51).EQ.1) GOTO 130
3519 C...Finalize interleaved MI/ISR/JI evolution.
3520 CALL PYEVOL(2,PT2MAX,PT2MIN)
3521 IF (MINT(51).EQ.1) GOTO 130
3526 IF(MINT(51).EQ.1) GOTO 100
3527 C...(MINT(52) is actually obsolete in this routine. Set anyway
3528 C...to ensure PYDOCU stable.)
3532 C...Beam remnants - new scheme.
3533 140 IF(MINT(50).EQ.1) THEN
3534 IF (ISUB.EQ.95) MINT(31)=1
3536 C...Beam remnant flavour and colour assignments - new scheme.
3538 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3540 IF(MINT(51).EQ.1) GOTO 100
3542 C...Primordial kT and beam remnant momentum sharing - new scheme.
3544 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3546 IF(MINT(51).EQ.1) GOTO 100
3547 IF (ISUB.EQ.95) MINT(31)=0
3548 ELSEIF(MINT(111).NE.12) THEN
3549 C...Hadron remnants and primordial kT - old model.
3550 C...Happens e.g. for direct photon on one side.
3553 CALL PYREMN(IPU1,IPU2)
3554 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3556 IF(MINT(51).EQ.1) GOTO 100
3557 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3558 DO 160 I=MINT(53)+1,N
3560 IDA=MOD(K(I,KCS),MSTU(5))
3562 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3568 C...Instruct PYPREP to use colour tags
3570 C...Now delete any colour processing information if set (since partons
3571 C...otherwise not FS showered!)
3572 DO 170 I=MINT(84)+1,N
3574 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3575 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3580 C...Showering of final state partons (optional).
3583 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3586 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3587 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3591 C...Decay of final state resonances.
3593 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3595 IF(MINT(51).NE.0) GOTO 100
3597 C...External processes: handle successive showers.
3598 ELSEIF(ISET(ISUB).EQ.11) THEN
3601 IF(MINT(51).EQ.1) GOTO 100
3603 ELSEIF(ISUB.NE.99) THEN
3604 C...Diffractive and elastic scattering.
3608 C...DIS scattering (photon flux external).
3610 IF(MINT(51).EQ.1) GOTO 100
3613 C...Check that no odd resonance left undecayed.
3615 IF(MSTP(111).GE.1) THEN
3617 DO 180 I=MINT(84)+1,NFIX
3618 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3619 & K(I,2).NE.22) THEN
3621 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3623 IF(MINT(51).EQ.1) GOTO 100
3629 C...Boost hadronic subsystem to overall rest frame.
3630 C..(Only relevant when photon inside lepton beam.)
3631 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3633 C...Recalculate energies from momenta and masses (if desired).
3634 IF(MSTP(113).GE.1) THEN
3635 DO 190 I=MINT(83)+1,N
3636 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3637 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3642 C...Colour reconnection before string formation
3643 CALL PYFSCR(MINT(84)+1)
3645 C...Rearrange partons along strings, check invariant mass cuts.
3647 IF(MSTP(111).LE.0) MSTJ(14)=-1
3648 CALL PYPREP(MINT(84)+1)
3650 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3654 IF(MINT(51).EQ.1) GOTO 110
3655 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3656 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3657 DO 220 I=MINT(84)+1,N
3658 IF(K(I,2).EQ.94) THEN
3659 DO 210 I1=I+1,MIN(N,I+10)
3660 IF(K(I1,3).EQ.I) THEN
3661 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3662 IF(K(I1,3).EQ.0) THEN
3663 DO 200 II=MINT(84)+1,I-1
3664 IF(K(II,2).EQ.K(I1,2)) THEN
3665 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3666 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3669 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3677 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3678 IF(MSTP(125).EQ.0) MINT(4)=0
3679 DO 240 I=MINT(83)+1,N
3680 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3682 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3683 IF(K(I1,3).EQ.I) K(I,5)=I1
3689 C...Introduce separators between sections in PYLIST event listing.
3690 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3693 ELSEIF(IPILE.EQ.1) THEN
3700 C...Go back to lab frame (needed for vertices, also in fragmentation).
3703 C...Set nonvanishing production vertex (optional).
3704 IF(MSTP(151).EQ.1) THEN
3706 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3707 & SIN(PARU(2)*PYR(0))
3709 DO 270 I=MINT(83)+1,N
3711 V(I,J)=V(I,J)+VTX(J)
3716 C...Perform hadronization (if desired).
3717 IF(MSTP(111).GE.1) THEN
3719 IF(MSTU(24).NE.0) GOTO 100
3721 IF(MSTP(113).GE.1) THEN
3723 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3724 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3727 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3729 C...Store event information and calculate Monte Carlo estimates of
3730 C...subprocess cross-sections.
3731 290 IF(IPILE.EQ.1) CALL PYDOCU
3733 C...Set counters for current pileup event and loop to next one.
3735 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3736 IF(MSTU70.LT.10) THEN
3741 MINT(84)=N+MSTP(126)
3742 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3745 C...Generic information on pileup events. Reconstruct missing history.
3746 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3750 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3754 C...Transform to the desired coordinate frame.
3755 310 CALL PYFRAM(MSTP(124))
3760 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3761 &1X,'Execution stopped.')
3767 C***********************************************************************
3770 C...Prints out information about cross-sections, decay widths, branching
3771 C...ratios, kinematical limits, status codes and parameter values.
3773 SUBROUTINE PYSTAT(MSTAT)
3775 C...Double precision and integer declarations.
3776 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3777 IMPLICIT INTEGER(I-N)
3778 INTEGER PYK,PYCHGE,PYCOMP
3779 C...Parameter statement to help give large particle numbers.
3780 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3781 &KEXCIT=4000000,KDIMEN=5000000)
3782 PARAMETER (EPS=1D-3)
3784 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3785 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3786 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3787 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3788 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3789 COMMON/PYINT1/MINT(400),VINT(400)
3790 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3791 COMMON/PYINT4/MWID(500),WIDS(500,5)
3792 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3793 COMMON/PYINT6/PROC(0:500)
3794 CHARACTER PROC*28, CHTMP*16
3795 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3796 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3797 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3798 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3799 C...Local arrays, character variables and data.
3800 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3801 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3802 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3803 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3804 CHARACTER*24 CHD0, CHDC(10)
3805 CHARACTER*6 DNAME(3)
3807 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3808 &'VMD/hadron * anomalous ','direct * direct ',
3809 &'direct * anomalous ','anomalous * anomalous '/
3810 DATA DISGA/'e * VMD','e * anomalous'/
3812 &'direct * direct ','direct * VMD ',
3813 &'direct * anomalous ','VMD * direct ',
3814 &'VMD * VMD ','VMD * anomalous ',
3815 &'anomalous * direct ','anomalous * VMD ',
3816 &'anomalous * anomalous ','DIS * VMD ',
3817 &'DIS * anomalous ','VMD * DIS ',
3818 &'anomalous * DIS '/
3820 &'direct * direct ','direct * resolved ',
3821 &'resolved * direct ','resolved * resolved '/
3823 &'direct * hadron ','resolved * hadron '/
3825 &'VMD * hadron ','direct * hadron ',
3826 &'anomalous * hadron ','DIS * hadron '/
3827 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3828 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3829 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3830 &' y*_small ',' eta*_large ',' eta*_small ',
3831 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3832 &' x_2 ',' x_F ',' cos(theta_hard) ',
3833 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3834 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3836 DATA DNAME /'q ','lepton','nu '/
3840 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3841 WRITE(MSTU(11),5000)
3842 WRITE(MSTU(11),5100)
3843 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3845 IF(MSUB(I).NE.1) GOTO 100
3846 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3848 IF(MINT(121).GT.1) THEN
3849 WRITE(MSTU(11),5300)
3850 DO 110 IGA=1,MINT(121)
3852 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3853 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3855 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3856 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3858 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3859 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3861 ELSEIF(MINT(121).EQ.4) THEN
3862 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3864 ELSEIF(MINT(121).EQ.2) THEN
3865 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3868 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3874 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3875 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3877 C...Decay widths and branching ratios.
3878 ELSEIF(MSTAT.EQ.2) THEN
3879 WRITE(MSTU(11),5500)
3880 WRITE(MSTU(11),5600)
3883 CALL PYNAME(KF,CHKF)
3886 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3887 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3888 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3889 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3890 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3892 IF(MWID(KC).LE.0) GOTO 140
3893 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3894 & KF/KSUSY1.EQ.2)) GOTO 140
3896 C...Off-shell branchings.
3899 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3900 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3901 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3902 DO 120 J=1,MDCY(KC,3)
3905 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3906 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3908 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3909 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3910 CALL PYNAME(KFDP(IDC,1),CHD1)
3911 CALL PYNAME(KFDP(IDC,2),CHD2)
3912 IF(KFDP(IDC,3).EQ.0) THEN
3913 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3914 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3915 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3917 CALL PYNAME(KFDP(IDC,3),CHD3)
3918 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3919 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3920 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3923 C...On-shell decays.
3925 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3927 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3928 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3929 & STATE(MDCY(KC,1)),BRFIN
3930 DO 130 J=1,MDCY(KC,3)
3933 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3934 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3936 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3937 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3939 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
3941 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3942 CALL PYNAME(KFDP(IDC,1),CHD1)
3943 CALL PYNAME(KFDP(IDC,2),CHD2)
3944 IF(KFDP(IDC,3).EQ.0) THEN
3945 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3946 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3947 & CHD2(1:10),WDTP(J),BRPRI,
3948 & STATE(MDME(IDC,1)),BRFIN
3950 CALL PYNAME(KFDP(IDC,3),CHD3)
3951 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3952 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3953 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
3954 & STATE(MDME(IDC,1)),BRFIN
3959 WRITE(MSTU(11),6000)
3961 C...Allowed incoming partons/particles at hard interaction.
3962 ELSEIF(MSTAT.EQ.3) THEN
3963 WRITE(MSTU(11),6100)
3964 CALL PYNAME(MINT(11),CHAU)
3966 CALL PYNAME(MINT(12),CHAU)
3968 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3972 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3973 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3975 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3978 WRITE(MSTU(11),6400)
3980 C...User-defined limits on kinematical variables.
3981 ELSEIF(MSTAT.EQ.4) THEN
3982 WRITE(MSTU(11),6500)
3983 WRITE(MSTU(11),6600)
3985 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3986 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3987 PTHMIN=MAX(CKIN(3),CKIN(5))
3989 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3990 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3991 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3993 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3996 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3997 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3998 WRITE(MSTU(11),7000)
4000 C...Status codes and parameter values.
4001 ELSEIF(MSTAT.EQ.5) THEN
4002 WRITE(MSTU(11),7100)
4003 WRITE(MSTU(11),7200)
4005 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4009 C...List of all processes implemented in the program.
4010 ELSEIF(MSTAT.EQ.6) THEN
4011 WRITE(MSTU(11),7400)
4012 WRITE(MSTU(11),7500)
4014 IF(ISET(I).LT.0) GOTO 180
4015 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4017 WRITE(MSTU(11),7700)
4019 ELSEIF(MSTAT.EQ.7) THEN
4020 WRITE (MSTU(11),8000)
4026 KFSUSY=ILR*KSUSY1+KFSM
4029 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4035 CALL PYNAME(KFSUSY,CHTMP)
4037 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4038 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4039 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4041 DO 200 J=1,MDCY(KC,3)
4043 ID1=IABS(KFDP(IDC,1))
4044 ID2=IABS(KFDP(IDC,2))
4045 IF (KFDP(IDC,3).EQ.0) THEN
4046 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4047 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4048 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4049 NMODES(1)=NMODES(1)+1
4050 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4051 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4052 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4053 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4054 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4055 NMODES(2)=NMODES(2)+1
4056 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4057 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4058 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4059 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4060 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4061 NMODES(3)=NMODES(3)+1
4062 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4063 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4069 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4075 CALL PYNAME(KFSUSY,CHTMP)
4077 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4078 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4080 DO 220 J=1,MDCY(KC,3)
4082 ID1=IABS(KFDP(IDC,1))
4083 ID2=IABS(KFDP(IDC,2))
4084 IF (KFDP(IDC,3).EQ.0) THEN
4085 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4086 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4087 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4088 NMODES(1)=NMODES(1)+1
4089 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4090 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4091 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4092 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4093 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4094 NMODES(2)=NMODES(2)+1
4095 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4096 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4102 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4108 CALL PYNAME(KFSUSY,CHTMP)
4110 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4111 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4113 DO 240 J=1,MDCY(KC,3)
4115 ID1=IABS(KFDP(IDC,1))
4116 ID2=IABS(KFDP(IDC,2))
4117 IF (KFDP(IDC,3).EQ.0) THEN
4118 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4119 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4120 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4121 NMODES(1)=NMODES(1)+1
4122 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4123 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4125 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4126 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4127 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4128 NMODES(2)=NMODES(2)+1
4129 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4130 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4135 C...SNEUTRINO DECAYS
4136 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4143 CALL PYNAME(KFSUSY,CHTMP)
4145 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4146 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4148 DO 260 J=1,MDCY(KC,3)
4150 ID1=IABS(KFDP(IDC,1))
4151 ID2=IABS(KFDP(IDC,2))
4152 IF (KFDP(IDC,3).EQ.0) THEN
4153 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4154 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4155 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4156 NMODES(1)=NMODES(1)+1
4157 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4158 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4160 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4161 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4162 NMODES(2)=NMODES(2)+1
4163 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4164 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4165 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4170 IF (NRVDC.NE.0) THEN
4172 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4173 NMODES(0)=NMODES(0)+NMODES(I)
4181 C...NEUTRALINO DECAYS
4182 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4188 CALL PYNAME(KFSUSY,CHTMP)
4190 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4191 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4192 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4193 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4195 DO 310 J=1,MDCY(KC,3)
4197 ID1=IABS(KFDP(IDC,1))
4198 ID2=IABS(KFDP(IDC,2))
4199 ID3=IABS(KFDP(IDC,3))
4200 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4201 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4202 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4203 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4204 NMODES(1)=NMODES(1)+1
4205 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4206 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4207 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4208 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4209 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4210 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4211 NMODES(2)=NMODES(2)+1
4212 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4213 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4214 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4215 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4216 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4217 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4218 NMODES(3)=NMODES(3)+1
4219 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4220 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4221 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4222 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4223 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4224 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4225 NMODES(4)=NMODES(4)+1
4226 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4227 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4232 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4238 CALL PYNAME(KFSUSY,CHTMP)
4240 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4241 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4242 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4243 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4244 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4246 DO 330 J=1,MDCY(KC,3)
4248 ID1=IABS(KFDP(IDC,1))
4249 ID2=IABS(KFDP(IDC,2))
4250 ID3=IABS(KFDP(IDC,3))
4251 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4252 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4253 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4254 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4255 NMODES(1)=NMODES(1)+1
4256 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4257 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4258 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4259 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4260 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4261 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4262 NMODES(1)=NMODES(1)+1
4263 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4264 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4265 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4266 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4267 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4268 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4269 NMODES(2)=NMODES(2)+1
4270 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4271 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4272 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4273 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4274 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4275 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4276 NMODES(3)=NMODES(3)+1
4277 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4278 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4279 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4280 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4281 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4282 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4283 NMODES(3)=NMODES(3)+1
4284 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4285 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4286 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4287 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4288 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4289 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4290 NMODES(4)=NMODES(4)+1
4291 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4292 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4293 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4294 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4295 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4296 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4297 NMODES(4)=NMODES(4)+1
4298 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4299 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4300 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4301 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4302 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4303 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4304 NMODES(5)=NMODES(5)+1
4305 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4306 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4307 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4308 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4309 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4310 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4311 NMODES(5)=NMODES(5)+1
4312 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4313 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4318 IF (KFSM.EQ.21) THEN
4324 CALL PYNAME(KFSUSY,CHTMP)
4326 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4327 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4328 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4330 DO 350 J=1,MDCY(KC,3)
4332 ID1=IABS(KFDP(IDC,1))
4333 ID2=IABS(KFDP(IDC,2))
4334 ID3=IABS(KFDP(IDC,3))
4335 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4336 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4337 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4338 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4339 NMODES(1)=NMODES(1)+1
4340 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4341 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4342 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4343 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4344 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4345 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4346 NMODES(2)=NMODES(2)+1
4347 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4348 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4349 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4350 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4351 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4352 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4353 NMODES(3)=NMODES(3)+1
4354 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4355 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4360 IF (NRVDC.NE.0) THEN
4362 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4363 NMODES(0)=NMODES(0)+NMODES(I)
4367 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4369 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4370 WRITE (MSTU(11),8500)
4374 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4375 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4379 WRITE (MSTU(11),8600)
4383 C...Formats for printouts.
4384 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4385 &'Events and Cross-sections',1X,9('*'))
4386 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4387 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4388 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4389 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4390 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4391 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4393 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4395 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4396 &1X,'I',34X,'I',28X,'I',12X,'I')
4397 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4398 &1X,'********* Total number of errors, excluding junctions =',
4399 &1X,I8,' *************'/
4400 &1X,'********* Total number of errors, including junctions =',
4401 &1X,I8,' *************'/
4402 &1X,'********* Total number of warnings = ',
4403 &1X,I8,' *************'/
4404 &1X,'********* Fraction of events that fail fragmentation ',
4405 &'cuts =',1X,F8.5,' *********'/)
4406 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4407 &'Ratios',1X,27('*'))
4408 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4409 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4410 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4411 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4413 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4414 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4415 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4416 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4417 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4418 &1P,D10.3,0P,1X,'I')
4419 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4420 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4421 &1P,D10.3,0P,1X,'I')
4422 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4423 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4424 &'Particles at Hard Interaction',1X,7('*'))
4425 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4426 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4427 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4428 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4429 &78('=')/1X,'I',38X,'I',37X,'I')
4430 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4431 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4432 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4433 &'Kinematical Variables',1X,12('*'))
4434 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4435 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4437 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4438 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4439 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4440 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4441 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4442 &'Parameter Values',1X,12('*'))
4443 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4445 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4446 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4448 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4449 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4450 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4451 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4452 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4454 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4455 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4456 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4457 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4458 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4459 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4460 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4461 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4462 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4464 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4465 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4466 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4468 & 1X,'R-Violating couplings',1X/ 1X /
4470 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4471 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4472 & ,'I',15X,'I',15X,'I',15X,'I')
4473 8600 FORMAT(1X,55('='))
4474 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4475 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4480 C*********************************************************************
4483 C...Administers the hard-process generation required for output to the
4484 C...Les Houches event record.
4488 C...Double precision and integer declarations.
4489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4490 IMPLICIT INTEGER(I-N)
4491 INTEGER PYK,PYCHGE,PYCOMP
4494 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4495 COMMON/PYCTAG/NCT,MCT(4000,2)
4496 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4497 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4498 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4499 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4500 COMMON/PYINT1/MINT(400),VINT(400)
4501 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4502 COMMON/PYINT4/MWID(500),WIDS(500,5)
4503 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4504 &/PYINT1/,/PYINT2/,/PYINT4/
4506 C...HEPEUP for output.
4508 PARAMETER (MAXNUP=500)
4509 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4510 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4511 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4512 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4513 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4516 C...Stop if no subprocesses on.
4517 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4518 WRITE(MSTU(11),5100)
4522 C...Special flags for hard-process generation only.
4528 C...Initial values for some counters.
4539 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4542 C...If variable energies: redo incoming kinematics and cross-section.
4544 IF(MSTP(171).EQ.1) THEN
4546 IF(MSTI(61).EQ.1) THEN
4550 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4554 C...Do not allow pileup events.
4557 C...Generate variables of hard scattering.
4561 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4566 IF(MSTI(61).EQ.1) THEN
4570 IF(MINT(51).EQ.2) RETURN
4573 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4574 C...Hard scattering (including low-pT):
4575 C...reconstruct kinematics and colour flow of hard scattering.
4580 IF(MINT(51).EQ.1) GOTO 100
4584 C...Decay of final state resonances.
4586 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4588 IF(MINT(51).EQ.1) GOTO 100
4591 C...Longitudinal boost of hard scattering.
4592 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4593 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4595 ELSEIF(ISUB.NE.99) THEN
4596 C...Diffractive and elastic scattering.
4600 C...DIS scattering (photon flux external).
4602 IF(MINT(51).EQ.1) GOTO 100
4605 C...Check that no odd resonance left undecayed.
4608 DO 120 I=MINT(84)+1,NFIX
4609 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4610 & K(I,2).NE.22) THEN
4612 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4614 IF(MINT(51).EQ.1) GOTO 100
4619 C...Boost hadronic subsystem to overall rest frame.
4620 C..(Only relevant when photon inside lepton beam.)
4621 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4623 C...Store event information and calculate Monte Carlo estimates of
4624 C...subprocess cross-sections.
4627 C...Transform to the desired coordinate frame.
4628 140 CALL PYFRAM(MSTP(124))
4632 C...Restore special flags for hard-process generation only.
4636 C...Trace colour tags; convert to LHA style labels.
4638 DO 150 I=MINT(84)+1,N
4642 DO 160 I=MINT(84)+1,N
4643 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4644 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4645 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4647 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4648 IDA=MOD(K(I,4),MSTU(5))
4649 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4650 & MCT(IMO,2).NE.0) THEN
4652 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4653 & MCT(IMO,1).NE.0) THEN
4655 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4656 & MCT(IDA,2).NE.0) THEN
4663 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4665 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4666 IDA=MOD(K(I,5),MSTU(5))
4667 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4668 & MCT(IMO,1).NE.0) THEN
4670 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4671 & MCT(IMO,2).NE.0) THEN
4673 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4674 & MCT(IDA,1).NE.0) THEN
4684 C...Put event in HEPEUP commonblock.
4692 IDUP(I)=K(I+MINT(84),2)
4697 ELSEIF(K(I+4,3).EQ.0) THEN
4703 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4706 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4707 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4708 ICOLUP(1,I)=MCT(I+MINT(84),1)
4709 ICOLUP(2,I)=MCT(I+MINT(84),2)
4711 PUP(J,I)=P(I+MINT(84),J)
4717 C...Optionally write out event to disk. Minimal size for time/spin fields.
4718 IF(MSTP(162).GT.0) THEN
4719 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4721 IF(VTIMUP(I).EQ.0D0) THEN
4722 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4723 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4726 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4727 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4732 C...Optional extra line with parton-density information.
4733 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4734 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4737 C...Error messages and other print formats.
4738 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4739 &1X,'Execution stopped.')
4740 5200 FORMAT(1P,2I6,4E14.6)
4741 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4742 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4743 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4748 C*********************************************************************
4751 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4752 C...processes, and optionally stores that information on file.
4756 C...Double precision and integer declarations.
4757 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4758 IMPLICIT INTEGER(I-N)
4761 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4762 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4763 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4764 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4765 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4767 C...User process initialization commonblock.
4769 PARAMETER (MAXPUP=100)
4770 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4771 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4772 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4773 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4777 C...Store info on incoming beams.
4787 C...Event weighting strategy.
4790 C...Info on individual processes.
4793 IF(MSUB(ISUB).EQ.1) THEN
4795 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4796 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4802 C...Write info to file.
4803 IF(MSTP(161).GT.0) THEN
4804 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4805 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4807 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4812 C...Formats for printout.
4813 5100 FORMAT(1P,2I8,2E14.6,6I6)
4814 5200 FORMAT(1P,3E14.6,I6)
4820 C*********************************************************************
4822 C...Combine the two old-style Pythia initialization and event files
4823 C...into a single Les Houches Event File.
4827 C...Double precision and integer declarations.
4828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4829 IMPLICIT INTEGER(I-N)
4831 C...PYTHIA commonblock: only used to provide read/write units and version.
4832 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4835 C...User process initialization commonblock.
4837 PARAMETER (MAXPUP=100)
4838 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4839 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4840 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4841 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4845 C...User process event common block.
4847 PARAMETER (MAXNUP=500)
4848 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4849 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4850 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4851 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4852 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4855 C...Lines to read in assumed never longer than 200 characters.
4856 PARAMETER (MAXLEN=200)
4857 CHARACTER*(MAXLEN) STRING
4859 C...Format for reading lines.
4862 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4864 C...Rewind initialization and event files.
4868 C...Write header info.
4869 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4870 WRITE(MSTP(163),'(A)') '<!--'
4871 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4872 &MSTP(181),'.',MSTP(182)
4873 WRITE(MSTP(163),'(A)') '-->'
4875 C...Read first line of initialization info and get number of processes.
4876 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4877 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4878 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4880 C...Copy initialization lines, omitting trailing blanks.
4881 C...Embed in <init> ... </init> block.
4882 WRITE(MSTP(163),'(A)') '<init>'
4884 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4887 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4888 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4890 WRITE(MSTP(163),'(A)') '</init>'
4892 C...Begin event loop. Read first line of event info or already done.
4893 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4896 C...Look at first line to know number of particles in event.
4897 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4899 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4900 WRITE(MSTP(163),'(A)') '<event>'
4902 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4905 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4906 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4909 C...Copy trailing comment lines - with a # in the first column - as is.
4910 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4911 IF(STRING(1:1).EQ.'#') THEN
4914 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4915 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4919 C..End the <event> block. Loop back to look for next event.
4920 WRITE(MSTP(163),'(A)') '</event>'
4923 C...Successfully reached end of event loop: write closing tag
4924 C...and remove temporary intermediate files (unless asked not to).
4925 300 WRITE(MSTP(163),'(A)') '</event>'
4926 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4927 IF(MSTP(164).EQ.1) RETURN
4928 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4929 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4933 400 WRITE(*,*) ' PYLHEF file joining failed!'
4938 C*********************************************************************
4941 C...Calculates full and effective widths of gauge bosons, stores
4942 C...masses and widths, rescales coefficients to be used for
4943 C...resonance production generation.
4947 C...Double precision and integer declarations.
4948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4949 IMPLICIT INTEGER(I-N)
4950 INTEGER PYK,PYCHGE,PYCOMP
4951 C...Parameter statement to help give large particle numbers.
4952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4953 &KEXCIT=4000000,KDIMEN=5000000)
4955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4956 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4957 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4958 COMMON/PYDAT4/CHAF(500,2)
4960 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4961 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4962 COMMON/PYINT1/MINT(400),VINT(400)
4963 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4964 COMMON/PYINT4/MWID(500),WIDS(500,5)
4965 COMMON/PYINT6/PROC(0:500)
4967 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4968 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
4969 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
4970 C...Local arrays and data.
4971 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
4972 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
4974 C...Born level couplings in MSSM Higgs doublet sector.
4977 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
4979 IF(MSTP(4).EQ.2) THEN
4981 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
4985 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
4986 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
4988 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
4989 WRITE(MSTU(11),5000)
4992 PMAS(35,1)=SQRT(SQMHP)
4993 PMAS(36,1)=SQRT(SQMA)
4994 PMAS(37,1)=SQRT(SQMHC)
4995 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5000 PARU(161)=-SIN(ALSU)/COS(BESU)
5001 PARU(162)=COS(ALSU)/SIN(BESU)
5003 PARU(164)=SIN(BESU-ALSU)
5005 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5006 PARU(171)=COS(ALSU)/COS(BESU)
5007 PARU(172)=SIN(ALSU)/SIN(BESU)
5009 PARU(174)=COS(BESU-ALSU)
5011 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5013 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5014 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5020 PARU(186)=COS(BESU-ALSU)
5021 PARU(187)=SIN(BESU-ALSU)
5025 PARU(195)=COS(BESU-ALSU)
5028 C...Reset effective widths of gauge bosons.
5035 C...Order resonances by increasing mass (except Z0 and W+/-).
5039 IF(KF.EQ.0) GOTO 140
5040 IF(MWID(KC).EQ.0) GOTO 140
5041 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5042 IF(MSTP(1).LE.3) GOTO 140
5044 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5045 IF(IMSS(1).LE.0) GOTO 140
5049 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5050 DO 120 I1=NRES-1,1,-1
5051 IF(PMRES.GE.PMORD(I1)) GOTO 130
5052 KCORD(I1+1)=KCORD(I1)
5053 PMORD(I1+1)=PMORD(I1)
5059 C...Loop over possible resonances.
5064 C...Check that no fourth generation channels on by mistake.
5065 IF(MSTP(1).LE.3) THEN
5066 DO 150 J=1,MDCY(KC,3)
5068 KFA1=IABS(KFDP(IDC,1))
5069 KFA2=IABS(KFDP(IDC,2))
5070 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5071 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5076 C...Check that no supersymmetric channels on by mistake.
5077 IF(IMSS(1).LE.0) THEN
5078 DO 160 J=1,MDCY(KC,3)
5080 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5081 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5082 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5087 C...Find mass and evaluate width.
5089 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5090 IF(MWID(KC).EQ.3) MINT(63)=1
5091 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5094 C...Evaluate suppression factors due to non-simulated channels.
5095 IF(KCHG(KC,3).EQ.0) THEN
5097 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5098 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5099 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5100 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5101 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5106 IF(MWID(KC).EQ.3) MINT(63)=1
5107 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5110 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5111 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5112 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5113 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5114 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5115 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5116 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5117 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5118 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5119 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5120 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5121 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5122 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5125 C...Set resonance widths and branching ratios;
5126 C...also on/off switch for decays.
5127 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5129 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5130 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5131 DO 170 J=1,MDCY(KC,3)
5134 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5139 C...Flavours of leptoquark: redefine charge and name.
5140 KFLQQ=KFDP(MDCY(42,2),1)
5141 KFLQL=KFDP(MDCY(42,2),2)
5142 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5143 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5145 IF(IABS(KFLQL).EQ.13) LL=2
5146 IF(IABS(KFLQL).EQ.15) LL=3
5147 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5148 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5149 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5151 C...Special cases in treatment of gamma*/Z0: redefine process name.
5152 IF(MSTP(43).EQ.1) THEN
5153 PROC(1)='f + fbar -> gamma*'
5154 PROC(15)='f + fbar -> g + gamma*'
5155 PROC(19)='f + fbar -> gamma + gamma*'
5156 PROC(30)='f + g -> f + gamma*'
5157 PROC(35)='f + gamma -> f + gamma*'
5158 ELSEIF(MSTP(43).EQ.2) THEN
5159 PROC(1)='f + fbar -> Z0'
5160 PROC(15)='f + fbar -> g + Z0'
5161 PROC(19)='f + fbar -> gamma + Z0'
5162 PROC(30)='f + g -> f + Z0'
5163 PROC(35)='f + gamma -> f + Z0'
5164 ELSEIF(MSTP(43).EQ.3) THEN
5165 PROC(1)='f + fbar -> gamma*/Z0'
5166 PROC(15)='f + fbar -> g + gamma*/Z0'
5167 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5168 PROC(30)='f + g -> f + gamma*/Z0'
5169 PROC(35)='f + gamma -> f + gamma*/Z0'
5172 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5173 IF(MSTP(44).EQ.1) THEN
5174 PROC(141)='f + fbar -> gamma*'
5175 ELSEIF(MSTP(44).EQ.2) THEN
5176 PROC(141)='f + fbar -> Z0'
5177 ELSEIF(MSTP(44).EQ.3) THEN
5178 PROC(141)='f + fbar -> Z''0'
5179 ELSEIF(MSTP(44).EQ.4) THEN
5180 PROC(141)='f + fbar -> gamma*/Z0'
5181 ELSEIF(MSTP(44).EQ.5) THEN
5182 PROC(141)='f + fbar -> gamma*/Z''0'
5183 ELSEIF(MSTP(44).EQ.6) THEN
5184 PROC(141)='f + fbar -> Z0/Z''0'
5185 ELSEIF(MSTP(44).EQ.7) THEN
5186 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5189 C...Special cases in treatment of WW -> WW: redefine process name.
5190 IF(MSTP(45).EQ.1) THEN
5191 PROC(77)='W+ + W+ -> W+ + W+'
5192 ELSEIF(MSTP(45).EQ.2) THEN
5193 PROC(77)='W+ + W- -> W+ + W-'
5194 ELSEIF(MSTP(45).EQ.3) THEN
5195 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5198 C...Format for error information.
5199 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5200 &'combination'/1X,'Execution stopped!')
5205 C*********************************************************************
5208 C...Identifies the two incoming particles and the choice of frame.
5210 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5212 C...Double precision and integer declarations.
5213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5214 IMPLICIT INTEGER(I-N)
5215 INTEGER PYK,PYCHGE,PYCOMP
5217 C...User process initialization commonblock.
5219 PARAMETER (MAXPUP=100)
5220 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5221 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5222 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5223 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5233 COMMON/PYINT1/MINT(400),VINT(400)
5234 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5236 C...Local arrays, character variables and data.
5237 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5238 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5239 DIMENSION LEN(3),KCDE(39),PM(2)
5240 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5241 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5242 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5243 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5244 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5245 &'nu_taubar ','pi+ ','pi- ','n0 ',
5246 &'nbar0 ','p+ ','pbar- ','gamma ',
5247 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5248 &'xi- ','xi0 ','omega- ','pi0 ',
5249 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5250 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5251 &'k+ ','k- ','ks0 ','kl0 '/
5252 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5253 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5254 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5256 C...Store initial energy. Default frame.
5260 C...Special user process initialization; convert to normal input.
5261 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5263 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5264 CALL PYNAME(IDBMUP(1),CHNAME)
5266 CALL PYNAME(IDBMUP(2),CHNAME)
5270 C...Convert character variables to lowercase and find their length.
5277 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5279 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5285 C...Fix up bar, underscore and charge in particle name (if needed).
5287 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5289 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5292 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5294 CHIDNT(I)='nu_'//CHTEMP(3:7)
5295 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5296 CHIDNT(I)(1:3)='n0 '
5297 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5298 CHIDNT(I)(1:5)='nbar0'
5299 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5300 CHIDNT(I)(1:3)='p+ '
5301 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5302 & CHIDNT(I)(1:2).EQ.'p-') THEN
5303 CHIDNT(I)(1:5)='pbar-'
5304 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5306 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5307 CHIDNT(I)(1:7)='reggeon'
5308 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5309 CHIDNT(I)(1:7)='pomeron'
5313 C...Identify free initialization.
5314 IF(CHCOM(1)(1:2).EQ.'no') THEN
5319 C...Identify incoming beam and target particles.
5322 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5324 PM(I)=PYMASS(MINT(10+I))
5327 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5328 CHTEMP=CHIDNT(I+1)(7:12)//' '
5330 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5332 PM(I)=PYMASS(MINT(140+I))
5336 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5337 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5338 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
5340 C...Identify choice of frame and input energies.
5343 C...Events defined in the CM frame.
5344 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5347 IF(MSTP(122).GE.1) THEN
5348 IF(CHCOM(2)(1:1).NE.'e') THEN
5349 LOFFS=(31-(LEN(2)+LEN(3)))/2
5350 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5351 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5354 LOFFS=(30-(LEN(2)+LEN(3)))/2
5355 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5356 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5359 WRITE(MSTU(11),5200) CHINIT
5360 WRITE(MSTU(11),5300) WIN
5363 C...Events defined in fixed target frame.
5364 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5366 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5367 IF(MSTP(122).GE.1) THEN
5368 LOFFS=(29-(LEN(2)+LEN(3)))/2
5369 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5370 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5371 & ' fixed target'//' '
5372 WRITE(MSTU(11),5200) CHINIT
5373 WRITE(MSTU(11),5400) WIN
5374 WRITE(MSTU(11),5500) SQRT(S)
5377 C...Frame defined by user three-vectors.
5378 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5382 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5383 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5384 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5385 & (P(1,3)+P(2,3))**2
5386 IF(MSTP(122).GE.1) THEN
5387 LOFFS=(22-(LEN(2)+LEN(3)))/2
5388 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5389 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5390 & ' user configuration'//' '
5391 WRITE(MSTU(11),5200) CHINIT
5392 WRITE(MSTU(11),5600)
5393 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5394 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5395 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5398 C...Frame defined by user four-vectors.
5399 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5401 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5402 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5403 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5404 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5405 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5406 & (P(1,3)+P(2,3))**2
5407 IF(MSTP(122).GE.1) THEN
5408 LOFFS=(22-(LEN(2)+LEN(3)))/2
5409 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5410 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5411 & ' user configuration'//' '
5412 WRITE(MSTU(11),5200) CHINIT
5413 WRITE(MSTU(11),5600)
5414 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5415 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5416 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5419 C...Frame defined by user five-vectors.
5420 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5422 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5423 & (P(1,3)+P(2,3))**2
5424 IF(MSTP(122).GE.1) THEN
5425 LOFFS=(22-(LEN(2)+LEN(3)))/2
5426 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5427 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5428 & ' user configuration'//' '
5429 WRITE(MSTU(11),5200) CHINIT
5430 WRITE(MSTU(11),5600)
5431 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5432 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5433 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5436 C...Frame defined by HEPRUP common block.
5437 ELSEIF(MINT(111).GE.11) THEN
5438 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5439 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5440 IF(MSTP(122).GE.1) THEN
5441 LOFFS=(22-(LEN(2)+LEN(3)))/2
5442 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5443 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5444 & ' user configuration'//' '
5445 WRITE(MSTU(11),5200) CHINIT
5446 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5447 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5450 C...Unknown frame. Error for too low CM energy.
5452 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5455 IF(S.LT.PARP(2)**2) THEN
5456 WRITE(MSTU(11),5900) SQRT(S)
5460 C...Formats for initialization and error information.
5461 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5462 &1X,'Execution stopped!')
5463 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5464 &1X,'Execution stopped!')
5465 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5466 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5467 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5468 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5469 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5470 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5471 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5472 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5473 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5474 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5475 &1X,'Execution stopped!')
5476 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5477 &'generation.'/1X,'Execution stopped!')
5478 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5479 &'GeV beam energies',13X,'I')
5484 C*********************************************************************
5487 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5489 SUBROUTINE PYINKI(MODKI)
5491 C...Double precision and integer declarations.
5492 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5493 IMPLICIT INTEGER(I-N)
5494 INTEGER PYK,PYCHGE,PYCOMP
5496 C...User process initialization commonblock.
5498 PARAMETER (MAXPUP=100)
5499 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5500 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5501 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5502 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5507 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5508 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5509 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5510 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5512 COMMON/PYINT1/MINT(400),VINT(400)
5513 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5515 C...Set initial flavour state.
5520 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5523 C...Reset boost. Do kinematics for various cases.
5528 C...Set up kinematics for events defined in CM frame.
5529 IF(MINT(111).EQ.1) THEN
5531 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5535 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5536 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5541 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5544 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5545 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5547 C...Set up kinematics for fixed target events.
5548 ELSEIF(MINT(111).EQ.2) THEN
5550 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5553 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5554 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5560 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5563 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5564 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5565 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5567 C...Set up kinematics for events in user-defined frame.
5568 ELSEIF(MINT(111).EQ.3) THEN
5571 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5572 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5573 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5574 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5576 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5578 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5579 VINT(7)=PYANGL(P(1,1),P(1,2))
5580 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5581 VINT(6)=PYANGL(P(1,3),P(1,1))
5582 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5583 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5585 C...Set up kinematics for events with user-defined four-vectors.
5586 ELSEIF(MINT(111).EQ.4) THEN
5587 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5588 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5589 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5590 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5592 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5594 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5595 VINT(7)=PYANGL(P(1,1),P(1,2))
5596 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5597 VINT(6)=PYANGL(P(1,3),P(1,1))
5598 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5599 S=(P(1,4)+P(2,4))**2
5601 C...Set up kinematics for events with user-defined five-vectors.
5602 ELSEIF(MINT(111).EQ.5) THEN
5604 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5606 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5607 VINT(7)=PYANGL(P(1,1),P(1,2))
5608 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5609 VINT(6)=PYANGL(P(1,3),P(1,1))
5610 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5611 S=(P(1,4)+P(2,4))**2
5613 C...Set up kinematics for events with external user processes.
5614 ELSEIF(MINT(111).GE.11) THEN
5617 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5618 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5623 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5624 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5627 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5628 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5629 S=(P(1,4)+P(2,4))**2
5632 C...Return or error for too low CM energy.
5633 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5634 IF(MSTP(172).LE.1) THEN
5636 & '(PYINKI:) too low invariant mass in this event')
5643 C...Save information on incoming particles.
5646 IF(MINT(111).GE.4) THEN
5647 IF(MINT(141).EQ.0) THEN
5649 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5653 IF(MINT(142).EQ.0) THEN
5655 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5661 IF(MODKI.EQ.0) VINT(289)=S
5669 C...Store pT cut-off and related constants to be used in generation.
5670 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5671 IF(MSTP(82).LE.1) THEN
5672 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5674 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5676 VINT(149)=4D0*PTMN**2/S
5682 C*********************************************************************
5685 C...Selects partonic subprocesses to be included in the simulation.
5689 C...Double precision and integer declarations.
5690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5691 IMPLICIT INTEGER(I-N)
5692 INTEGER PYK,PYCHGE,PYCOMP
5694 C...User process initialization commonblock.
5696 PARAMETER (MAXPUP=100)
5697 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5698 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5699 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5700 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5704 C...Commonblocks and character variables.
5705 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5706 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5707 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5708 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5709 COMMON/PYINT1/MINT(400),VINT(400)
5710 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5711 COMMON/PYINT6/PROC(0:500)
5713 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5717 C...Reset processes to be included.
5724 C...Set running pTmin scale.
5725 IF(MSTP(82).LE.1) THEN
5726 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5728 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5731 C...Begin by assuming incoming photon to enter subprocess.
5732 IF(MINT(11).EQ.22) MINT(15)=22
5733 IF(MINT(12).EQ.22) MINT(16)=22
5735 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5736 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5738 MINT(123)=MINT(122)+1
5740 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5742 C...Here also set a few parameters otherwise normally not touched.
5743 ELSEIF(MINT(121).GT.1) THEN
5745 C...Parton distributions dampened at small Q2; go to low energies,
5746 C...alpha_s <1; no minimum pT cut-off a priori.
5747 IF(MSTP(18).EQ.2) THEN
5755 C...Define pT cut-off parameters and whether run involves low-pT.
5759 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5761 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5762 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5764 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5765 IF(MSEL.EQ.2) IPTL=1
5767 C...Set up for p/gamma * gamma; real or virtual photons.
5768 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5769 & MSTP(14).EQ.30)) THEN
5771 C...Set up for p/VMD * VMD.
5772 IF(MINT(122).EQ.1) THEN
5780 IF(IPTL.EQ.1) MSUB(95)=1
5787 IF(IPTL.EQ.1) CKIN(3)=0D0
5789 C...Set up for p/VMD * direct gamma.
5790 ELSEIF(MINT(122).EQ.2) THEN
5792 IF(MINT(121).EQ.6) MINT(123)=5
5797 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5799 C...Set up for p/VMD * anomalous gamma.
5800 ELSEIF(MINT(122).EQ.3) THEN
5802 IF(MINT(121).EQ.6) MINT(123)=7
5809 IF(IPTL.EQ.1) MSUB(95)=1
5816 IF(IPTL.EQ.1) CKIN(3)=0D0
5818 C...Set up for DIS * p.
5819 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5820 & IABS(MINT(12)).GT.100)) THEN
5822 IF(IPTL.EQ.1) MSUB(99)=1
5824 C...Set up for direct * direct gamma (switch off leptons).
5825 ELSEIF(MINT(122).EQ.4) THEN
5831 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5832 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5834 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5836 C...Set up for direct * anomalous gamma.
5837 ELSEIF(MINT(122).EQ.5) THEN
5843 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5845 C...Set up for anomalous * anomalous gamma.
5846 ELSEIF(MINT(122).EQ.6) THEN
5854 IF(IPTL.EQ.1) MSUB(95)=1
5861 IF(IPTL.EQ.1) CKIN(3)=0D0
5864 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5865 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5867 C...Set up for direct * direct gamma (switch off leptons).
5868 IF(MINT(122).EQ.1) THEN
5874 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5875 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5877 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5879 C...Set up for direct * VMD and VMD * direct gamma.
5880 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5886 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5888 C...Set up for direct * anomalous and anomalous * direct gamma.
5889 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5895 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5897 C...Set up for VMD*VMD.
5898 ELSEIF(MINT(122).EQ.5) THEN
5906 IF(IPTL.EQ.1) MSUB(95)=1
5913 IF(IPTL.EQ.1) CKIN(3)=0D0
5915 C...Set up for VMD * anomalous and anomalous * VMD gamma.
5916 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5924 IF(IPTL.EQ.1) MSUB(95)=1
5931 IF(IPTL.EQ.1) CKIN(3)=0D0
5933 C...Set up for anomalous * anomalous gamma.
5934 ELSEIF(MINT(122).EQ.9) THEN
5942 IF(IPTL.EQ.1) MSUB(95)=1
5949 IF(IPTL.EQ.1) CKIN(3)=0D0
5951 C...Set up for DIS * VMD and VMD * DIS gamma.
5952 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
5954 IF(IPTL.EQ.1) MSUB(99)=1
5956 C...Set up for DIS * anomalous and anomalous * DIS gamma.
5957 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
5959 IF(IPTL.EQ.1) MSUB(99)=1
5962 C...Set up for gamma* * p; virtual photons = dir, res.
5963 ELSEIF(MINT(121).EQ.2) THEN
5965 C...Set up for direct * p.
5966 IF(MINT(122).EQ.1) THEN
5972 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5974 C...Set up for resolved * p.
5975 ELSEIF(MINT(122).EQ.2) THEN
5983 IF(IPTL.EQ.1) MSUB(95)=1
5990 IF(IPTL.EQ.1) CKIN(3)=0D0
5993 C...Set up for gamma* * gamma*; virtual photons = dir, res.
5994 ELSEIF(MINT(121).EQ.4) THEN
5996 C...Set up for direct * direct gamma (switch off leptons).
5997 IF(MINT(122).EQ.1) THEN
6003 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6004 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6006 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6008 C...Set up for direct * resolved and resolved * direct gamma.
6009 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6015 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6017 C...Set up for resolved * resolved gamma.
6018 ELSEIF(MINT(122).EQ.4) THEN
6026 IF(IPTL.EQ.1) MSUB(95)=1
6033 IF(IPTL.EQ.1) CKIN(3)=0D0
6036 C...End of special set up for gamma-p and gamma-gamma.
6041 C...Flavour information for individual beams.
6044 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6045 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6046 MINT(44+I)=MINT(40+I)
6047 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6048 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6051 C...If two real gammas, whereof one direct, pick the first.
6052 C...For two virtual photons, keep requested order.
6053 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6054 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6057 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6058 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6061 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6062 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6065 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6066 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6069 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6070 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6073 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6076 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6080 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6081 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6082 IF(MINT(11).EQ.22) THEN
6090 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6091 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6094 C...Flavour information on combination of incoming particles.
6095 MINT(43)=2*MINT(41)+MINT(42)-2
6097 IF(MINT(123).LE.0) THEN
6098 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6099 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6100 ELSEIF(MINT(123).LE.3) THEN
6101 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6102 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6103 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6107 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6108 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6109 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6110 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6112 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6115 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6116 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6118 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6120 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6121 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6122 & MINT(122).EQ.10) MINT(108)=2
6123 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6124 & MINT(122).EQ.11) MINT(108)=3
6125 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6126 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6127 IF(MINT(122).GE.3) MINT(107)=1
6128 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6129 ELSEIF(MINT(121).EQ.2) THEN
6130 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6131 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6133 IF(MINT(11).EQ.22) THEN
6135 IF(MINT(123).GE.4) MINT(107)=0
6136 IF(MINT(123).EQ.7) MINT(107)=2
6137 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6138 IF(MSTP(14).EQ.28) MINT(107)=2
6139 IF(MSTP(14).EQ.29) MINT(107)=3
6140 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6143 IF(MINT(12).EQ.22) THEN
6145 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6146 IF(MINT(123).EQ.7) MINT(108)=3
6147 IF(MSTP(14).EQ.26) MINT(108)=2
6148 IF(MSTP(14).EQ.27) MINT(108)=3
6149 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6150 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6153 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6154 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6160 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6161 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6163 C...Select default processes according to incoming beams
6164 C...(already done for gamma-p and gamma-gamma with
6165 C...MSTP(14) = 10, 20, 25 or 30).
6166 IF(MINT(121).GT.1) THEN
6167 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6169 IF(MINT(43).EQ.1) THEN
6170 C...Lepton + lepton -> gamma/Z0 or W.
6171 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6172 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6174 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6175 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6176 C...Unresolved photon + lepton: Compton scattering.
6180 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6181 & .OR.MINT(12).EQ.22)) THEN
6182 C...DIS as pure gamma* + f -> f process.
6185 ELSEIF(MINT(43).LE.3) THEN
6186 C...Lepton + hadron: deep inelastic scattering.
6189 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6190 & MINT(12).EQ.22) THEN
6191 C...Two unresolved photons: fermion pair production,
6192 C...exclude lepton pairs.
6196 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6197 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6200 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6201 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6202 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6204 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6205 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6206 & MINT(12).EQ.22)) THEN
6207 C...Unresolved photon + hadron: photon-parton scattering.
6212 ELSEIF(MSEL.EQ.1) THEN
6213 C...High-pT QCD processes:
6222 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6223 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6226 C...All QCD processes:
6240 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6241 C...Heavy quark production.
6245 DO 180 J=1,MIN(8,MDCY(21,3))
6246 MDME(MDCY(21,2)+J-1,1)=0
6248 MDME(MDCY(21,2)+MSEL-1,1)=1
6250 DO 190 J=1,MIN(12,MDCY(22,3))
6251 MDME(MDCY(22,2)+J-1,1)=0
6253 MDME(MDCY(22,2)+MSEL-1,1)=1
6255 ELSEIF(MSEL.EQ.10) THEN
6256 C...Prompt photon production:
6261 ELSEIF(MSEL.EQ.11) THEN
6262 C...Z0/gamma* production:
6265 ELSEIF(MSEL.EQ.12) THEN
6266 C...W+/- production:
6269 ELSEIF(MSEL.EQ.13) THEN
6274 ELSEIF(MSEL.EQ.14) THEN
6279 ELSEIF(MSEL.EQ.15) THEN
6280 C...Z0 & W+/- pair production:
6287 ELSEIF(MSEL.EQ.16) THEN
6295 ELSEIF(MSEL.EQ.17) THEN
6296 C...h0 & Z0 or W+/- pair production:
6300 ELSEIF(MSEL.EQ.18) THEN
6301 C...h0 production; interesting processes in e+e-.
6307 ELSEIF(MSEL.EQ.19) THEN
6308 C...h0, H0 and A0 production; interesting processes in e+e-.
6322 ELSEIF(MSEL.EQ.21) THEN
6326 ELSEIF(MSEL.EQ.22) THEN
6327 C...W'+/- production:
6330 ELSEIF(MSEL.EQ.23) THEN
6331 C...H+/- production:
6334 ELSEIF(MSEL.EQ.24) THEN
6338 ELSEIF(MSEL.EQ.25) THEN
6339 C...LQ (leptoquark) production.
6345 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6346 C...Production of one heavy quark (W exchange):
6348 DO 200 J=1,MIN(8,MDCY(21,3))
6349 MDME(MDCY(21,2)+J-1,1)=0
6351 MDME(MDCY(21,2)+MSEL-31,1)=1
6353 CMRENNA++Define SUSY alternatives.
6354 ELSEIF(MSEL.EQ.39) THEN
6355 C...Turn on all SUSY processes.
6356 IF(MINT(43).EQ.4) THEN
6357 C...Hadron-hadron processes.
6359 IF(ISET(I).GE.0) MSUB(I)=1
6361 ELSEIF(MINT(43).EQ.1) THEN
6362 C...Lepton-lepton processes: QED production of squarks.
6379 ELSEIF(MSEL.EQ.40) THEN
6380 C...Gluinos and squarks.
6381 IF(MINT(43).EQ.4) THEN
6393 ELSEIF(MINT(43).EQ.1) THEN
6398 ELSEIF(MSEL.EQ.41) THEN
6399 C...Stop production.
6403 IF(MINT(43).EQ.4) THEN
6408 ELSEIF(MSEL.EQ.42) THEN
6409 C...Slepton production.
6413 IF(MINT(43).NE.4) THEN
6419 ELSEIF(MSEL.EQ.43) THEN
6420 C...Neutralino/Chargino + Gluino/Squark.
6421 IF(MINT(43).EQ.4) THEN
6431 ELSEIF(MSEL.EQ.44) THEN
6432 C...Neutralino/Chargino pair production.
6433 IF(MINT(43).EQ.4) THEN
6437 ELSEIF(MINT(43).EQ.1) THEN
6443 ELSEIF(MSEL.EQ.45) THEN
6444 C...Sbottom production.
6447 IF(MINT(43).EQ.4) THEN
6453 ELSEIF(MSEL.EQ.50) THEN
6454 C...Pair production of technipions and gauge bosons.
6458 IF(MINT(43).EQ.4) THEN
6464 ELSEIF(MSEL.EQ.51) THEN
6465 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6470 ELSEIF(MSEL.EQ.61) THEN
6471 C...Charmonium production in colour octet model, with recoiling parton.
6476 ELSEIF(MSEL.EQ.62) THEN
6477 C...Bottomonium production in colour octet model, with recoiling parton.
6482 ELSEIF(MSEL.EQ.63) THEN
6483 C...Charmonium and bottomonium production in colour octet model.
6490 C...Find heaviest new quark flavour allowed in processes 81-84.
6492 DO 350 I=1,MIN(8,MDCY(21,3))
6494 IF(MDME(IDC,1).LE.0) GOTO 350
6497 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6508 C...Find heaviest new fermion flavour allowed in process 85.
6510 DO 360 I=1,MIN(12,MDCY(22,3))
6512 IF(MDME(IDC,1).LE.0) GOTO 360
6515 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6516 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6521 C...Import relevant information on external user processes.
6522 IF(MINT(111).GE.11) THEN
6525 C...Find next empty PYTHIA process number slot and enable it.
6527 IF(IPYPR.GT.500) CALL PYERRM(26,
6528 & '(PYINPR.) no more empty slots for user processes')
6529 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6530 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6532 C...Overwrite KFPR with references back to process number and ID.
6534 KFPR(IPYPR,2)=LPRUP(IUP)
6536 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6539 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6541 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6542 C...Switch on process.
6550 C*********************************************************************
6553 C...Parametrizes total, elastic and diffractive cross-sections
6554 C...for different energies and beams. Donnachie-Landshoff for
6555 C...total and Schuler-Sjostrand for elastic and diffractive.
6556 C...Process code IPROC:
6563 C...= 7 : J/psi + p;
6564 C...= 11 : rho + rho;
6565 C...= 12 : rho + phi;
6566 C...= 13 : rho + J/psi;
6567 C...= 14 : phi + phi;
6568 C...= 15 : phi + J/psi;
6569 C...= 16 : J/psi + J/psi;
6570 C...= 21 : gamma + p (DL);
6571 C...= 22 : gamma + p (VDM).
6572 C...= 23 : gamma + pi (DL);
6573 C...= 24 : gamma + pi (VDM);
6574 C...= 25 : gamma + gamma (DL);
6575 C...= 26 : gamma + gamma (VDM).
6579 C...Double precision and integer declarations.
6580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6581 IMPLICIT INTEGER(I-N)
6582 INTEGER PYK,PYCHGE,PYCOMP
6584 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6585 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6586 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6587 COMMON/PYINT1/MINT(400),VINT(400)
6588 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6589 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6590 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6592 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6593 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6594 &CEFFD(10,9),SIGTMP(6,0:5)
6596 C...Common constants.
6597 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6598 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6601 C...Number of multiple processes to be evaluated (= 0 : undefined).
6602 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6603 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6604 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6605 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6606 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6608 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6609 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6610 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6612 C...Beam and target hadron class:
6613 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6614 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6615 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6616 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6617 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6618 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6619 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6621 C...Fitting constants used in parametrizations of diffractive results.
6622 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6623 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6624 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6625 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6626 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6627 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6628 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6629 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6630 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6631 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6632 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6633 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6634 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6635 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6636 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6637 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6638 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6639 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6640 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6641 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6642 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6643 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6644 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6645 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6646 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6647 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6648 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6649 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6650 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6652 C...Parameters. Combinations of the energy.
6661 C...Ratio of gamma/pi (for rescaling in parton distributions).
6662 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6663 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6665 IF(MINT(50).NE.1) RETURN
6667 C...Order flavours of incoming particles: KF1 < KF2.
6668 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6677 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6679 C...Find process number (for lookup tables).
6680 IF(KF1.GT.1000) THEN
6682 IF(ISGN12.LT.0) IPROC=2
6683 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6685 IF(ISGN12.LT.0) IPROC=4
6686 IF(KF1.EQ.111) IPROC=5
6687 ELSEIF(KF1.GT.100) THEN
6689 ELSEIF(KF2.GT.1000) THEN
6691 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6692 ELSEIF(KF2.GT.100) THEN
6694 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6697 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6700 C... Number of multiple processes to be stored; beam/target side.
6706 ELSEIF(NPR.EQ.6) THEN
6711 IF(MINT(101).EQ.4) N1=4
6713 IF(MINT(102).EQ.4) N2=4
6715 C...Do not do any more for user-set or undefined cross-sections.
6716 IF(MSTP(31).LE.0) RETURN
6717 IF(NPR.EQ.0) CALL PYERRM(26,
6718 &'(PYXTOT:) cross section for this process not yet implemented')
6720 C...Parameters. Combinations of the energy.
6729 C...Loop over multiple processes (for VDM).
6733 ELSEIF(NPR.EQ.3) THEN
6735 IF(KF2.LT.1000) IPR=I+10
6736 ELSEIF(NPR.EQ.6) THEN
6740 C...Evaluate hadron species, mass, slope contribution and fit number.
6750 C...Skip if energy too low relative to masses.
6754 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6756 C...Total cross-section. Elastic slope parameter and cross-section.
6757 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6758 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6759 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6761 C...Diffractive scattering A + B -> X + B.
6764 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6765 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6766 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6767 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6768 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6769 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6770 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6772 C...Diffractive scattering A + B -> A + X.
6775 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6776 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6777 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6778 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6779 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6780 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6781 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6783 C...Order single diffractive correctly.
6786 SIGTMP(I,2)=SIGTMP(I,3)
6790 C...Double diffractive scattering A + B -> X1 + X2.
6791 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6792 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6793 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6794 IF(YEFF.LE.0) SUM1=0D0
6795 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6796 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6797 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6798 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6800 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6801 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6802 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6804 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6805 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6806 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6807 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6808 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6810 C...Non-diffractive by unitarity.
6811 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6815 C...Put temporary results in output array: only one process.
6816 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6818 SIGT(0,0,J)=SIGTMP(1,J)
6821 C...Beam multiple processes.
6822 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6823 IF(MINT(107).EQ.2) THEN
6824 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6826 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6827 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6829 IF(MSTP(20).GT.0) THEN
6830 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6833 IF(MINT(107).EQ.2) THEN
6834 CONV=(AEM/PARP(160+I))*VINT(317)
6835 ELSEIF(VINT(154).GT.PARP(15)) THEN
6836 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6837 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6843 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6847 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6850 C...Target multiple processes.
6851 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6852 IF(MINT(108).EQ.2) THEN
6853 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6855 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6856 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6858 IF(MSTP(20).GT.0) THEN
6859 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6862 IF(MINT(108).EQ.2) THEN
6863 CONV=(AEM/PARP(160+I))*VINT(317)
6864 ELSEIF(VINT(154).GT.PARP(15)) THEN
6865 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6866 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6872 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6876 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6879 C...Both beam and target multiple processes.
6881 IF(MINT(107).EQ.2) THEN
6882 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6884 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6885 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6887 IF(MINT(108).EQ.2) THEN
6888 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6890 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6891 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6893 IF(MSTP(20).GT.0) THEN
6894 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6895 & VINT(308)))**MSTP(20)
6899 IF(MINT(107).EQ.2) THEN
6900 CONV=(AEM/PARP(160+I1))*VINT(317)
6901 ELSEIF(VINT(154).GT.PARP(15)) THEN
6902 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6903 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6907 IF(MINT(108).EQ.2) THEN
6908 CONV=CONV*(AEM/PARP(160+I2))
6909 ELSEIF(VINT(154).GT.PARP(15)) THEN
6910 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6911 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6917 ELSEIF(I2.LE.2) THEN
6919 ELSEIF(I1.EQ.I2) THEN
6926 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6927 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6933 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
6934 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
6936 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6940 C...Scale up uniformly for Donnachie-Landshoff parametrization.
6941 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
6942 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
6946 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
6955 C*********************************************************************
6958 C...Finds optimal set of coefficients for kinematical variable selection
6959 C...and the maximum of the part of the differential cross-section used
6960 C...in the event weighting.
6964 C...Double precision and integer declarations.
6965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6966 IMPLICIT INTEGER(I-N)
6967 INTEGER PYK,PYCHGE,PYCOMP
6968 C...Parameter statement to help give large particle numbers.
6969 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
6970 &KEXCIT=4000000,KDIMEN=5000000)
6972 C...User process initialization commonblock.
6974 PARAMETER (MAXPUP=100)
6975 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6976 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6977 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6978 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
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/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6986 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6988 COMMON/PYINT1/MINT(400),VINT(400)
6989 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6990 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6991 COMMON/PYINT4/MWID(500),WIDS(500,5)
6992 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6993 COMMON/PYINT6/PROC(0:500)
6995 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6996 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6997 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
6998 C...Local arrays, character variables and data.
7000 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7001 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
7002 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7003 DATA CVAR/'tau ','tau''','y* ','cth '/
7006 C...Initial values and loop over subprocesses.
7015 C...Find maximum weight factors for photon flux.
7016 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7017 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7020 C...Select subprocess to study: skip cases not applicable.
7021 IF(ISET(ISUB).EQ.11) THEN
7022 IF(MSUB(ISUB).NE.1) GOTO 460
7023 C...User process intialization: cross section model dependent.
7024 IF(IABS(IDWTUP).EQ.1) THEN
7025 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7026 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7027 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7029 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7030 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7031 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7032 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7033 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7034 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7036 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7037 & WTGAGA*XSEC(ISUB,1)
7040 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7041 CALL PYSIGH(NCHN,SIGS)
7043 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7044 & WTGAGA*XSEC(ISUB,1)
7045 IF(MSUB(ISUB).NE.1) GOTO 460
7048 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7049 CALL PYSIGH(NCHN,SIGS)
7051 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7052 & WTGAGA*XSEC(ISUB,1)
7053 IF(XSEC(ISUB,1).EQ.0D0) THEN
7059 ELSEIF(ISUB.EQ.96) THEN
7060 IF(MINT(50).EQ.0) GOTO 460
7061 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7063 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7064 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7065 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7066 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7067 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7068 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7070 IF(MSUB(ISUB).NE.1) GOTO 460
7073 IF(ISUB.EQ.96) ISTSB=2
7074 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7076 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7077 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7079 C...Find resonances (explicit or implicit in cross-section).
7082 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7084 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7085 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7087 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7088 & .OR.ISUB.EQ.177) THEN
7090 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7092 IF(MSTP(46).EQ.5) THEN
7095 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7097 ELSEIF(ISUB.EQ.194) THEN
7099 ELSEIF(ISUB.EQ.195) THEN
7101 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7103 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7107 IF(CKMX.LE.0D0) CKMX=VINT(1)
7110 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7111 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7114 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7115 IF(KFR1.EQ.KTECHN+113) THEN
7119 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7126 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7129 IF(ISUB.EQ.194) THEN
7131 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7135 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7136 IF(KFR2.EQ.KTECHN+223) THEN
7140 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7141 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7142 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7143 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7148 ELSEIF(KFR2.NE.0) THEN
7160 C...Find product masses and minimum pT of process.
7166 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7170 IF(KFPR(ISUB,I).EQ.0) THEN
7171 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7173 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7174 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7177 C...This prevents SUSY/t particles from becoming too light.
7179 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7182 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7183 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7184 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7185 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7186 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7187 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7188 PMMN(I)=MIN(PMMN(I),PMSUM)
7191 ELSEIF(KFLW.EQ.6) THEN
7192 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7199 CKIN(41)=MAX(PMMN(1),CKIN(41))
7200 CKIN(43)=MAX(PMMN(2),CKIN(43))
7201 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7204 IF(MINT(51).EQ.1) THEN
7205 WRITE(MSTU(11),5100) ISUB
7212 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7213 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7214 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7215 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7216 ELSEIF(ISUB.EQ.96) THEN
7217 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7223 C...Prepare for additional variable choices in 2 -> 3.
7226 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7228 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7229 VINT(204)=PMAS(23,1)
7230 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7231 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7232 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7233 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7234 & VINT(204)=VINT(201)
7236 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7239 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7240 NPTS(1)=2+2*MINT(72)
7241 IF(MINT(47).EQ.1) THEN
7242 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7243 ELSEIF(MINT(47).GE.5) THEN
7244 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
7247 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7248 IF(MINT(47).GE.2) NPTS(2)=2
7249 IF(MINT(47).GE.5) NPTS(2)=3
7252 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7254 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7255 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7258 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7259 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7261 C...Reset coefficients of cross-section weighting.
7277 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7278 C...in grid of phase space points.
7284 IF(METAU.EQ.1) GOTO 150
7285 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7286 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7287 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
7289 C...Special case when both resonances have same mass,
7290 C...as is often the case in process 194.
7291 IF(MINT(72).EQ.2) THEN
7292 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7293 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7294 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7296 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7301 CALL PYKMAP(1,MTAU,RTAU)
7302 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7305 IF(METAUP.EQ.1) GOTO 150
7306 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7308 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7309 CALL PYKMAP(4,MTAUP,0.5D0)
7311 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7315 IF(MEYST.EQ.1) GOTO 150
7316 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7317 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7318 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7319 CALL PYKMAP(2,MYST,0.5D0)
7323 IF(MECTH.EQ.1) GOTO 150
7324 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7325 MCTH=1+MOD(ITRY-1,NPTS(4))
7326 CALL PYKMAP(3,MCTH,0.5D0)
7328 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7330 C...Store position and limits.
7333 IF(MINT(51).EQ.1) GOTO 150
7336 MVARPT(NACC,2)=MTAUP
7340 VINTPT(NACC,J)=VINT(10+J)
7343 C...Normal case: calculate cross-section.
7345 CALL PYSIGH(NCHN,SIGS)
7351 C..2 -> 3: find highest value out of a number of tries.
7354 DO 140 IKIN3=1,MSTP(129)
7355 CALL PYKMAP(5,0,0D0)
7356 IF(MINT(51).EQ.1) GOTO 140
7357 CALL PYSIGH(NCHN,SIGTMP)
7362 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7366 C...Store cross-section.
7368 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7369 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7370 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7373 WRITE(MSTU(11),5100) ISUB
7376 ELSEIF(SIGSAM.EQ.0D0) THEN
7377 WRITE(MSTU(11),5300) ISUB
7381 IF(ISUB.NE.96) NPOSI=NPOSI+1
7383 C...Calculate integrals in tau over maximal phase space limits.
7386 ATAU1=LOG(TAUMAX/TAUMIN)
7387 IF(NPTS(1).GE.2) THEN
7388 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7390 IF(NPTS(1).GE.4) THEN
7391 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7392 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7395 IF(NPTS(1).GE.6) THEN
7396 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7397 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7400 IF(NPTS(1).GT.2+2*MINT(72)) THEN
7401 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7404 C...Reset. Sum up cross-sections in points calculated.
7406 IF(NPTS(IVAR).EQ.1) GOTO 320
7407 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7418 IBIN=MVARPT(IACC,IVAR)
7419 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
7420 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7421 NAREL(IBIN)=NAREL(IBIN)+1
7422 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7424 C...Sum up tau cross-section pieces in points used.
7427 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7428 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7430 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7431 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7432 & ((TAU-TAUR1)**2+GAMR1**2)
7435 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7436 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7437 & ((TAU-TAUR2)**2+GAMR2**2)
7439 IF(NBIN.GT.2+2*MINT(72)) THEN
7440 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
7441 & TAU/MAX(2D-10,1D0-TAU)
7444 C...Sum up tau' cross-section pieces in points used.
7445 ELSEIF(IVAR.EQ.2) THEN
7447 TAUP=VINTPT(IACC,16)
7448 TAUPMN=VINTPT(IACC,6)
7449 TAUPMX=VINTPT(IACC,26)
7450 ATAUP1=LOG(TAUPMX/TAUPMN)
7451 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7452 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7453 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7454 & (1D0-TAU/TAUP)**3/TAUP
7456 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7457 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7458 & TAUP/MAX(2D-10,1D0-TAUP)
7461 C...Sum up y* cross-section pieces in points used.
7462 ELSEIF(IVAR.EQ.3) THEN
7464 YSTMIN=VINTPT(IACC,2)
7465 YSTMAX=VINTPT(IACC,22)
7467 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7469 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7470 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7471 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7472 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7473 IF(MINT(45).EQ.3) THEN
7474 TAUE=VINTPT(IACC,11)
7475 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7476 YST0=-0.5D0*LOG(TAUE)
7477 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7478 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7479 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7480 & MAX(1D-10,1D0-EXP(YST-YST0))
7482 IF(MINT(46).EQ.3) THEN
7483 TAUE=VINTPT(IACC,11)
7484 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7485 YST0=-0.5D0*LOG(TAUE)
7486 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7487 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7488 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7489 & MAX(1D-10,1D0-EXP(-YST-YST0))
7492 C...Sum up cos(theta-hat) cross-section pieces in points used.
7494 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7496 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7498 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7501 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7502 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7503 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7504 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7506 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7507 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7508 & MAX(RM34,RSQM-CTH)
7509 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7510 & MAX(RM34,RSQM+CTH)
7511 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7512 & MAX(RM34,RSQM-CTH)**2
7513 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7514 & MAX(RM34,RSQM+CTH)**2
7518 C...Check that equation system solvable.
7519 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7523 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7524 & IRED=1,NBIN),WTREL(IBIN)
7525 IF(NAREL(IBIN).EQ.0) MSOLV=0
7526 WTRELS=WTRELS+WTREL(IBIN)
7528 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7530 C...Solve to find relative importance of cross-section pieces.
7533 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7535 DO 230 IRED=1,NBIN-1
7536 DO 220 IBIN=IRED+1,NBIN
7537 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7541 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7542 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7543 DO 210 ICOE=IRED,NBIN
7544 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7548 DO 250 IRED=NBIN,1,-1
7549 DO 240 ICOE=IRED+1,NBIN
7550 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7552 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7556 C...Share evenly if failure.
7557 260 IF(MSOLV.EQ.0) THEN
7561 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7562 & WTREL(IBIN)/WTRELS)
7566 C...Normalize coefficients, with piece shared democratically.
7570 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7571 COEFSU=COEFSU+COEFU(IBIN)
7572 WTRELS=WTRELS+WTRELN(IBIN)
7574 IF(COEFSU.GT.0D0) THEN
7576 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7577 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7581 COEFO(IBIN)=1D0/NBIN
7584 IF(IVAR.EQ.1) IOFF=0
7585 IF(IVAR.EQ.2) IOFF=17
7586 IF(IVAR.EQ.3) IOFF=7
7587 IF(IVAR.EQ.4) IOFF=12
7590 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
7591 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7592 COEF(ISUB,ICOF)=COEFO(IBIN)
7594 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7595 & (COEFO(IBIN),IBIN=1,NBIN)
7598 C...Find two most promising maxima among points previously determined.
7606 VINT(10+J)=VINTPT(IACC,J)
7609 CALL PYSIGH(NCHN,SIGS)
7616 DO 350 IKIN3=1,MSTP(129)
7617 CALL PYKMAP(5,0,0D0)
7618 IF(MINT(51).EQ.1) GOTO 350
7619 CALL PYSIGH(NCHN,SIGTMP)
7624 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7629 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7632 DO 370 IMV=NMAX,1,-1
7634 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7635 IACCMX(IMV+1)=IACCMX(IMV)
7636 SIGSMX(IMV+1)=SIGSMX(IMV)
7639 380 IACCMX(IIN)=IACC
7641 IF(NMAX.LE.1) NMAX=NMAX+1
7645 C...Read out starting position for search.
7646 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7651 MTAUP=MVARPT(IACC,2)
7659 C...Starting point and step size in parameter space.
7662 IF(NPTS(IVAR).EQ.1) GOTO 420
7663 IF(IVAR.EQ.1) VVAR=VTAU
7664 IF(IVAR.EQ.2) VVAR=VTAUP
7665 IF(IVAR.EQ.3) VVAR=VYST
7666 IF(IVAR.EQ.4) VVAR=VCTH
7667 IF(IVAR.EQ.1) MVAR=MTAU
7668 IF(IVAR.EQ.2) MVAR=MTAUP
7669 IF(IVAR.EQ.3) MVAR=MYST
7670 IF(IVAR.EQ.4) MVAR=MCTH
7671 IF(IRPT.EQ.1) VDEL=0.1D0
7672 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7674 IF(IRPT.EQ.1) VMAR=0.02D0
7675 IF(IRPT.EQ.2) VMAR=0.002D0
7677 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7680 C...Define new point in parameter space.
7684 ELSEIF(IMOV.EQ.1) THEN
7687 ELSEIF(IMOV.EQ.2) THEN
7690 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7691 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7697 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7698 & VVAR-2D0*VDEL.GT.VMAR) THEN
7704 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
7718 C...Convert to relevant variables and find derived new limits.
7722 CALL PYKMAP(1,MTAU,VTAU)
7723 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7725 IF(MINT(51).EQ.1) ILERR=1
7728 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
7730 IF(IVAR.EQ.2) VTAUP=VNEW
7731 CALL PYKMAP(4,MTAUP,VTAUP)
7733 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
7735 IF(MINT(51).EQ.1) ILERR=1
7737 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
7738 IF(IVAR.EQ.3) VYST=VNEW
7739 CALL PYKMAP(2,MYST,VYST)
7741 IF(MINT(51).EQ.1) ILERR=1
7743 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
7745 IF(IVAR.EQ.4) VCTH=VNEW
7746 CALL PYKMAP(3,MCTH,VCTH)
7748 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7750 C...Evaluate cross-section. Save new maximum. Final maximum.
7753 ELSEIF(ISTSB.NE.5) THEN
7754 CALL PYSIGH(NCHN,SIGS)
7761 DO 400 IKIN3=1,MSTP(129)
7762 CALL PYKMAP(5,0,0D0)
7763 IF(MINT(51).EQ.1) GOTO 400
7764 CALL PYSIGH(NCHN,SIGTMP)
7769 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7773 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7774 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
7775 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7780 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
7781 XSEC(ISUB,1)=1.05D0*SIGSAM
7782 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7783 & WTGAGA*XSEC(ISUB,1)
7785 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
7786 & PARP(174)*XSEC(ISUB,1)
7787 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
7791 C...Print summary table.
7792 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
7793 IF(MSTP(127).NE.1) THEN
7794 WRITE(MSTU(11),5900)
7797 WRITE(MSTU(11),6400)
7801 IF(MSTP(122).GE.1) THEN
7802 WRITE(MSTU(11),6000)
7803 WRITE(MSTU(11),6100)
7805 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
7806 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
7807 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
7809 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
7810 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
7811 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
7812 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
7813 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
7815 WRITE(MSTU(11),6300)
7818 C...Format statements for maximization results.
7819 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
7820 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
7821 &'cth',9X,'tau''',7X,'sigma')
7822 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
7823 &'phase space.'/1X,'Process switched off!')
7824 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
7825 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
7826 &'cross-section.'/1X,'Process switched off!')
7827 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
7828 5500 FORMAT(1X,1P,8D11.3)
7829 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
7830 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
7831 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
7832 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
7833 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
7834 &'cross-section.'/1X,'Execution stopped!')
7835 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
7836 &'cross-section maximum search',1X,8('*'))
7837 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
7838 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
7839 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
7840 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
7841 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
7842 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
7844 &1X,'Execution will stop if you try to generate events.')
7849 C*********************************************************************
7852 C...Initializes multiplicity distribution and selects mutliplicity
7853 C...of pileup events, i.e. several events occuring at the same
7856 SUBROUTINE PYPILE(MPILE)
7858 C...Double precision and integer declarations.
7859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7860 IMPLICIT INTEGER(I-N)
7861 INTEGER PYK,PYCHGE,PYCOMP
7863 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7864 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7865 COMMON/PYINT1/MINT(400),VINT(400)
7866 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7867 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
7868 C...Local arrays and saved variables.
7869 DIMENSION WTI(0:200)
7870 SAVE IMIN,IMAX,WTI,WTS
7872 C...Sum of allowed cross-sections for pileup events.
7874 VINT(131)=SIGT(0,0,5)
7875 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
7876 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
7877 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
7878 IF(MSTP(133).LE.0) RETURN
7880 C...Initialize multiplicity distribution at maximum.
7881 XNAVE=VINT(131)*PARP(131)
7882 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
7883 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
7886 WTN=WTI(INAVE)*INAVE
7888 C...Find shape of multiplicity distribution below maximum.
7890 DO 100 I=INAVE-1,1,-1
7891 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
7892 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
7893 IF(WTI(I).LT.1D-6) GOTO 110
7899 C...Find shape of multiplicity distribution above maximum.
7901 DO 120 I=INAVE+1,200
7902 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
7903 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
7904 IF(WTI(I).LT.1D-6) GOTO 130
7911 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
7912 & WTS/(WTS+WTI(1)/XNAVE)
7913 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
7914 IF(MSTP(133).GE.2) VINT(134)=XNAVE
7916 C...Pick multiplicity of pileup events.
7918 IF(MSTP(133).LE.0) THEN
7919 MINT(81)=MAX(1,MSTP(134))
7925 IF(WTR.LE.0D0) GOTO 150
7931 C...Format statement for error message.
7932 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
7933 &'crossing too large, ',1P,D12.4)
7938 C*********************************************************************
7941 C...Saves and restores parameter and cross section values for the
7942 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
7943 C...Also makes random choice between alternatives.
7945 SUBROUTINE PYSAVE(ISAVE,IGA)
7947 C...Double precision and integer declarations.
7948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7949 IMPLICIT INTEGER(I-N)
7950 INTEGER PYK,PYCHGE,PYCOMP
7952 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7953 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7954 COMMON/PYINT1/MINT(400),VINT(400)
7955 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7956 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7957 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7958 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
7959 C...Local arrays and saved variables.
7960 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
7961 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
7962 &INTCP(15,20),RECP(15,20)
7963 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
7965 C...Save list of subprocesses and cross-section information.
7969 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
7972 MSUBCP(IGA,ICP)=MSUB(I)
7974 COEFCP(IGA,ICP,J)=COEF(I,J)
7977 NGENCP(IGA,ICP,J)=NGEN(I,J)
7978 XSECCP(IGA,ICP,J)=XSEC(I,J)
7983 NGENCP(IGA,0,J)=NGEN(0,J)
7984 XSECCP(IGA,0,J)=XSEC(0,J)
7989 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
7994 C...Save various common process variables.
7996 INTCP(IGA,J)=MINT(40+J)
7998 INTCP(IGA,11)=MINT(101)
7999 INTCP(IGA,12)=MINT(102)
8000 INTCP(IGA,13)=MINT(107)
8001 INTCP(IGA,14)=MINT(108)
8002 INTCP(IGA,15)=MINT(123)
8004 RECP(IGA,2)=VINT(318)
8006 C...Save cross-section information only.
8007 ELSEIF(ISAVE.EQ.2) THEN
8008 DO 190 ICP=1,NCP(IGA)
8011 NGENCP(IGA,ICP,J)=NGEN(I,J)
8012 XSECCP(IGA,ICP,J)=XSEC(I,J)
8016 NGENCP(IGA,0,J)=NGEN(0,J)
8017 XSECCP(IGA,0,J)=XSEC(0,J)
8020 C...Choose between allowed alternatives.
8021 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8024 DO 210 IG=1,MINT(121)
8025 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8027 XSUMCP=XSUMCP*PYR(0)
8028 DO 220 IG=1,MINT(121)
8030 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8031 IF(XSUMCP.LE.0D0) GOTO 230
8036 C...Restore cross-section information.
8040 DO 270 ICP=1,NCP(IGA)
8042 MSUB(I)=MSUBCP(IGA,ICP)
8044 COEF(I,J)=COEFCP(IGA,ICP,J)
8047 NGEN(I,J)=NGENCP(IGA,ICP,J)
8048 XSEC(I,J)=XSECCP(IGA,ICP,J)
8052 NGEN(0,J)=NGENCP(IGA,0,J)
8053 XSEC(0,J)=XSECCP(IGA,0,J)
8058 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8063 C...Restore various common process variables.
8065 MINT(40+J)=INTCP(IGA,J)
8067 MINT(101)=INTCP(IGA,11)
8068 MINT(102)=INTCP(IGA,12)
8069 MINT(107)=INTCP(IGA,13)
8070 MINT(108)=INTCP(IGA,14)
8071 MINT(123)=INTCP(IGA,15)
8074 VINT(318)=RECP(IGA,2)
8076 C...Sum up cross-section info (for PYSTAT).
8077 ELSEIF(ISAVE.EQ.5) THEN
8088 DO 350 IG=1,MINT(121)
8089 DO 340 ICP=1,NCP(IG)
8091 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8092 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8093 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8094 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8096 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8097 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8098 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8099 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8106 C*********************************************************************
8109 C...For lepton beams it gives photon-hadron or photon-photon systems
8110 C...to be treated with the ordinary machinery and combines this with a
8111 C...description of the lepton -> lepton + photon branching.
8113 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8115 C...Double precision and integer declarations.
8116 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8117 IMPLICIT INTEGER(I-N)
8118 INTEGER PYK,PYCHGE,PYCOMP
8120 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8121 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8122 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8123 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8125 COMMON/PYINT1/MINT(400),VINT(400)
8126 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8127 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8129 C...Local variables and data statement.
8130 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8131 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8132 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8135 C...Initialize generation of photons inside leptons.
8138 C...Save quantities on incoming lepton system.
8142 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8144 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8145 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8146 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8148 C...Calculate range of x and Q2 values allowed in generation.
8150 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8151 IF(MINT(140+I).NE.0) THEN
8152 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8153 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8155 YMIN=MAX(CKIN(71+2*I),EPS)
8156 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8157 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8158 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8159 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8160 THEMIN=MAX(CKIN(67+2*I),0D0)
8161 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8162 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8163 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8164 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8165 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8166 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8167 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8168 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8169 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8170 C...W limits when lepton on one side only.
8171 IF(MINT(143-I).EQ.0) THEN
8172 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8173 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8174 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8179 C...W limits when lepton on both sides.
8180 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8181 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8182 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8183 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8184 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8185 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8186 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8187 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8188 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8189 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8191 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8192 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8196 C...Q2 and W values and photon flux weight factors for initialization.
8197 ELSEIF(IGAGA.EQ.2) THEN
8202 C...W value for photon on one or both sides, and for processes
8203 C...with gamma-gamma cross section peaked at small shat.
8204 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8205 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8206 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8207 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8208 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8209 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8210 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8212 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8213 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8215 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8217 C...Upper estimate of photon flux weight factor.
8218 C...Initialization Q2 scale. Flag incoming unresolved photon.
8221 IF(MINT(140+I).NE.0) THEN
8222 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8223 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8224 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8226 Q2INIT=5D0+Q2MIN(3-I)
8227 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8228 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8229 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8230 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8231 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8232 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8234 ELSEIF(ISUB.EQ.140) THEN
8239 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8240 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8242 VINT(306+I)=VINT(2+I)**2
8247 C...Update pTmin and cross section information.
8248 IF(MSTP(82).LE.1) THEN
8249 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8251 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8253 VINT(149)=4D0*PTMN**2/VINT(2)
8258 C...Generate photons inside leptons and
8259 C...calculate photon flux weight factors.
8260 ELSEIF(IGAGA.EQ.3) THEN
8265 C...Generate phase space point and check against cuts.
8269 IF(MINT(140+I).NE.0) THEN
8271 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8272 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8273 C...Cuts on internal consistency in x and Q2.
8274 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8275 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8276 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8277 C...Cuts on y and theta.
8278 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8279 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8280 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8281 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8282 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8283 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8284 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8287 C...Phi angle isotropic. Reconstruct pT.
8288 PHI(I)=PARU(2)*PYR(0)
8289 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8290 & PMS(I))*SIN(THETA(I))
8292 C...Store info on variables selected, for documentation purposes.
8293 VINT(2+I)=-SQRT(Q2(I))
8297 VINT(310+I)=THETA(I)
8308 C...Cut on W combines info from two sides.
8309 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8310 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8311 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8312 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8313 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8314 IF(W2.LT.W2MIN) GOTO 120
8315 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8318 ELSEIF(MINT(141).NE.0) THEN
8319 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8322 ELSEIF(MINT(142).NE.0) THEN
8323 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8328 C...Store kinematics info for photon(s) in subsystem cm frame.
8333 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8334 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8335 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8338 VINT(298)=-VINT(293)
8339 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8340 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8342 C...Assign weight for photon flux; different for transverse and
8343 C...longitudinal photons. Flag incoming unresolved photon.
8346 IF(MINT(140+I).NE.0) THEN
8347 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8348 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8349 IF(MSTP(16).EQ.0) THEN
8352 WTGAGA=WTGAGA*X(I)/Y(I)
8355 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8356 WTGAGA=WTGAGA*(1D0-XY)
8357 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8358 WTGAGA=WTGAGA*(1D0-XY)
8359 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8360 WTGAGA=WTGAGA*(1D0-XY)
8362 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8363 & PMS(I)*XY**2/Q2(I))
8365 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8371 C...Update pTmin and cross section information.
8372 IF(MSTP(82).LE.1) THEN
8373 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8375 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8377 VINT(149)=4D0*PTMN**2/VINT(2)
8381 C...Reconstruct kinematics of photons inside leptons.
8382 ELSEIF(IGAGA.EQ.4) THEN
8384 C...Make place for incoming particles and scattered leptons.
8386 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8387 MINT(4)=MINT(4)+MOVE
8388 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8389 IF(K(I,1).EQ.21) THEN
8395 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8396 & K(I+MOVE,3)=K(I,3)+MOVE
8397 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8398 & K(I+MOVE,4)=K(I,4)+MOVE
8399 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8400 & K(I+MOVE,5)=K(I,5)+MOVE
8403 DO 170 I=MINT(84)+1,N
8404 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8405 & K(I,3)=K(I,3)+MOVE
8408 C...Fill in incoming particles.
8409 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8418 IF(MINT(140+I).NE.0) THEN
8419 K(MINT(83)+I,2)=MINT(140+I)
8420 P(MINT(83)+I,5)=VINT(302+I)
8422 K(MINT(83)+I,2)=MINT(10+I)
8423 P(MINT(83)+I,5)=VINT(2+I)
8425 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8426 & VINT(302))*(-1D0)**(I+1)
8427 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8430 C...New mother-daughter relations in documentation section.
8431 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8432 K(MINT(83)+1,4)=MINT(83)+3
8433 K(MINT(83)+1,5)=MINT(83)+5
8434 K(MINT(83)+2,4)=MINT(83)+4
8435 K(MINT(83)+2,5)=MINT(83)+6
8436 K(MINT(83)+3,3)=MINT(83)+1
8437 K(MINT(83)+5,3)=MINT(83)+1
8438 K(MINT(83)+4,3)=MINT(83)+2
8439 K(MINT(83)+6,3)=MINT(83)+2
8440 ELSEIF(MINT(141).NE.0) THEN
8441 K(MINT(83)+1,4)=MINT(83)+3
8442 K(MINT(83)+1,5)=MINT(83)+4
8443 K(MINT(83)+2,4)=MINT(83)+5
8444 K(MINT(83)+3,3)=MINT(83)+1
8445 K(MINT(83)+4,3)=MINT(83)+1
8446 K(MINT(83)+5,3)=MINT(83)+2
8447 ELSEIF(MINT(142).NE.0) THEN
8448 K(MINT(83)+1,4)=MINT(83)+4
8449 K(MINT(83)+2,4)=MINT(83)+3
8450 K(MINT(83)+2,5)=MINT(83)+5
8451 K(MINT(83)+3,3)=MINT(83)+2
8452 K(MINT(83)+4,3)=MINT(83)+1
8453 K(MINT(83)+5,3)=MINT(83)+2
8456 C...Fill scattered lepton(s).
8458 IF(MINT(140+I).NE.0) THEN
8459 LSC=MINT(83)+MIN(I+2,MOVE)
8461 K(LSC,2)=MINT(140+I)
8462 P(LSC,1)=PT(I)*COS(PHI(I))
8463 P(LSC,2)=PT(I)*SIN(PHI(I))
8464 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8465 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8467 P(LSC,5)=VINT(302+I)
8471 C...Find incoming four-vectors to subprocess.
8473 IF(MINT(141).NE.0) THEN
8475 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8479 P(N+1,J)=P(MINT(83)+1,J)
8483 IF(MINT(142).NE.0) THEN
8485 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8489 P(N+2,J)=P(MINT(83)+2,J)
8493 C...Define boost and rotation between hadronic subsystem and
8494 C...collision rest frame; boost hadronic subsystem to this frame.
8496 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8498 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8499 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8500 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8501 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8502 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8505 C...Add on scattered leptons to final state.
8507 IF(MINT(140+I).NE.0) THEN
8508 LSC=MINT(83)+MIN(I+2,MOVE)
8524 C*********************************************************************
8527 C...Generates quantities characterizing the high-pT scattering at the
8528 C...parton level according to the matrix elements. Chooses incoming,
8529 C...reacting partons, their momentum fractions and one of the possible
8534 C...Double precision and integer declarations.
8535 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8536 IMPLICIT INTEGER(I-N)
8537 INTEGER PYK,PYCHGE,PYCOMP
8538 C...Parameter statement to help give large particle numbers.
8539 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8540 &KEXCIT=4000000,KDIMEN=5000000)
8542 C...User process initialization and event commonblocks.
8544 PARAMETER (MAXPUP=100)
8545 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8546 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8547 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8548 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8551 PARAMETER (MAXNUP=500)
8552 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8553 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8554 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8555 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8556 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8557 SAVE /HEPRUP/,/HEPEUP/
8560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8561 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8562 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8563 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8564 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8565 COMMON/PYINT1/MINT(400),VINT(400)
8566 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8567 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8568 COMMON/PYINT4/MWID(500),WIDS(500,5)
8569 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8570 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8571 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8572 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8573 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
8575 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8577 C...Parameters and data used in elastic/diffractive treatment.
8578 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8579 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8581 C...Initial values, specifically for (first) semihard interaction.
8590 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8599 C...Start by assuming incoming photon is entering subprocess.
8600 IF(MINT(11).EQ.22) THEN
8602 VINT(307)=VINT(3)**2
8604 IF(MINT(12).EQ.22) THEN
8606 VINT(308)=VINT(4)**2
8611 C...Choice of process type - first event of pileup.
8613 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8614 ELSEIF(MINT(82).EQ.1) THEN
8616 C...For gamma-p or gamma-gamma first pick between alternatives.
8618 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8621 C...For real gamma + gamma with different nature, flip at random.
8622 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8623 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8633 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8636 C...Pick process type, possibly by user process machinery.
8637 C...(If the latter, also event will be picked here.)
8638 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8641 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8646 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8647 & ISUB.LT.500) GOTO 110
8649 RSUB=XSEC(0,1)*PYR(0)
8651 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8654 IF(RSUB.LE.0D0) GOTO 130
8656 130 IF(ISUB.EQ.95) ISUB=96
8657 IF(ISUB.EQ.96) INMULT=1
8658 IF(ISET(ISUB).EQ.11) THEN
8665 C...Choice of inclusive process type - pileup events.
8666 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8667 RSUB=VINT(131)*PYR(0)
8669 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8670 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8671 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8672 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8674 IF(ISUB.EQ.96) INMULT=1
8677 C...Choice of photon energy and flux factor inside lepton.
8678 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8679 CALL PYGAGA(3,WTGAGA)
8680 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8681 CKIN(3)=MAX(VINT(285),VINT(154))
8684 C...When necessary set direct/resolved photon by hand.
8685 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8686 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8687 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8690 C...Restrict direct*resolved processes to pTmin >= Q,
8691 C...to avoid doublecounting with DIS.
8692 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8693 IF(MINT(15).EQ.22) THEN
8694 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
8696 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
8701 C...Set up for multiple interactions (may include impact parameter).
8702 IF(INMULT.EQ.1) THEN
8703 IF(MINT(35).LE.1) CALL PYMULT(2)
8704 IF(MINT(35).GE.2) CALL PYMIGN(2)
8707 C...Loopback point for minimum bias in photon physics.
8710 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
8711 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
8712 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
8713 &NGEN(97,1)=NGEN(97,1)+MINT(143)
8717 C...Random choice of flavour for some SUSY processes.
8718 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
8719 C...~e_L ~nu_e or ~mu_L ~nu_mu.
8720 IF(ISUB.EQ.210) THEN
8721 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
8722 KFPR(ISUB,2)=KFPR(ISUB,1)+1
8723 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
8724 ELSEIF(ISUB.EQ.213) THEN
8725 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
8726 KFPR(ISUB,2)=KFPR(ISUB,1)
8727 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
8728 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
8730 IF(ISUB.GE.258) THEN
8735 IF(MOD(ISUB,2).EQ.0) THEN
8736 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
8738 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
8740 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
8741 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
8742 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
8745 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
8748 ELSEIF(PYR(0).LT.0.5D0) THEN
8755 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
8756 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
8757 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
8758 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
8759 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
8760 KFPR(ISUB,2)=KFPR(ISUB,1)
8761 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
8762 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
8763 KFPR(ISUB,2)=KFPR(ISUB,1)
8764 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
8765 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
8766 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
8769 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
8772 ELSEIF(PYR(0).LT.0.5D0) THEN
8779 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
8784 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
8788 C...Find resonances (explicit or implicit in cross-section).
8791 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
8793 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
8794 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
8796 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
8799 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
8801 IF(MSTP(46).EQ.5) THEN
8804 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
8806 ELSEIF(ISUB.EQ.194) THEN
8808 ELSEIF(ISUB.EQ.195) THEN
8810 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
8812 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
8816 IF(CKMX.LE.0D0) CKMX=VINT(1)
8819 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
8820 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
8823 TAUR1=PMAS(KCR1,1)**2/VINT(2)
8824 IF(KFR1.EQ.KTECHN+113) THEN
8828 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
8834 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
8837 IF(ISUB.EQ.194) THEN
8839 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
8843 TAUR2=PMAS(KCR2,1)**2/VINT(2)
8844 IF(KFR2.EQ.KTECHN+223) THEN
8848 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
8849 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
8850 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
8851 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
8856 ELSEIF(KFR2.NE.0) THEN
8867 C...Find product masses and minimum pT of process,
8868 C...optionally with broadening according to a truncated Breit-Wigner.
8873 IF(MINT(82).GE.2) VINT(71)=0D0
8875 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8879 IF(KFPR(ISUB,I).EQ.0) THEN
8880 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
8882 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
8885 C...This prevents SUSY/t particles from becoming too light.
8887 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
8890 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
8891 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
8892 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
8893 & PMAS(PYCOMP(KFDP(IDC,2)),1)
8894 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
8895 & PMAS(PYCOMP(KFDP(IDC,3)),1)
8896 PMMN(I)=MIN(PMMN(I),PMSUM)
8899 ELSEIF(KFLW.EQ.6) THEN
8900 PMMN(I)=PMAS(24,1)+PMAS(5,1)
8907 CKIN(41)=MAX(PMMN(1),CKIN(41))
8908 CKIN(43)=MAX(PMMN(2),CKIN(43))
8909 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
8912 IF(MINT(51).EQ.1) THEN
8913 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8923 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
8924 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
8927 C...Prepare for additional variable choices in 2 -> 3.
8930 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
8932 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
8933 VINT(204)=PMAS(23,1)
8934 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
8935 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
8936 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
8937 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
8938 & VINT(204)=VINT(201)
8940 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
8943 C...Select incoming VDM particle (rho/omega/phi/J/psi).
8944 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
8945 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
8946 VRN=PYR(0)*SIGT(0,0,5)
8947 IF(MINT(101).LE.1) THEN
8954 IF(MINT(102).LE.1) THEN
8965 VRN=VRN-SIGT(I1,I2,5)
8966 IF(VRN.LE.0D0) GOTO 190
8969 190 IF(MINT(101).GE.2) MINT(103)=KFV1
8970 IF(MINT(102).GE.2) MINT(104)=KFV2
8974 C...Elastic scattering or single or double diffractive scattering.
8976 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
8981 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
8983 VRN=PYR(0)*SIGT(0,0,JJ)
8984 IF(MINT(101).LE.1) THEN
8991 IF(MINT(102).LE.1) THEN
9002 VRN=VRN-SIGT(I1,I2,JJ)
9003 IF(VRN.LE.0D0) GOTO 220
9006 220 IF(MINT(101).GE.2) THEN
9010 IF(MINT(102).GE.2) THEN
9018 C...Select mass for GVMD states (rejecting previous assignment).
9020 Q1S=4D0*VINT(154)**2
9024 IF(MINT(106+JT).EQ.3) THEN
9026 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9027 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9028 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9029 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9032 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9033 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9038 C...Side/sides of diffractive system.
9041 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9042 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9044 C...Find masses of particles and minimal masses of diffractive states.
9047 VINT(68+JT)=PDIF(JT)
9048 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9055 SMRES1=(PMM(1)+PMRC)**2
9056 SMRES2=(PMM(2)+PMRC)**2
9058 C...Find elastic slope and lower limit diffractive slope.
9059 IHA=MAX(2,IABS(MINT(103))/110)
9061 IHB=MAX(2,IABS(MINT(104))/110)
9064 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9065 ELSEIF(ISUB.EQ.92) THEN
9066 BMN=MAX(2D0,2D0*BHAD(IHB))
9067 ELSEIF(ISUB.EQ.93) THEN
9068 BMN=MAX(2D0,2D0*BHAD(IHA))
9069 ELSEIF(ISUB.EQ.94) THEN
9073 C...Determine maximum possible t range and coefficient of generation.
9074 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9075 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9076 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9077 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9078 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9079 & (SQM1*SQM4-SQM2*SQM3)/SH
9080 THL=-0.5D0*(THA+THB)
9082 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9084 C...Select diffractive mass/masses according to dm^2/m^2.
9088 IF(MINT(16+JT).EQ.0) THEN
9092 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9093 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9099 C..Additional mass factors, including resonance enhancement.
9100 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9101 IF(LOOP3.LT.100) GOTO 260
9105 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9106 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9107 ELSEIF(ISUB.EQ.93) THEN
9108 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9109 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9110 ELSEIF(ISUB.EQ.94) THEN
9111 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9112 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9113 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9114 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9117 C...Select t according to exp(Bmn*t) and correct to right slope.
9118 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9121 BADD=2D0*ALP*LOG(SH/SQM3)
9122 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9123 ELSEIF(ISUB.EQ.93) THEN
9124 BADD=2D0*ALP*LOG(SH/SQM4)
9125 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9126 ELSEIF(ISUB.EQ.94) THEN
9127 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9129 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9132 C...Check whether m^2 and t choices are consistent.
9133 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9134 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9135 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9136 IF(THB.LE.1D-8) GOTO 260
9137 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9138 & (SQM1*SQM4-SQM2*SQM3)/SH
9139 THLM=-0.5D0*(THA+THB)
9141 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9143 C...Information to output.
9146 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9148 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9151 VINT(283)=PMM(1)**2/4D0
9152 VINT(284)=PMM(2)**2/4D0
9154 C...Note: in the following, by In is meant the integral over the
9155 C...quantity multiplying coefficient cn.
9156 C...Choose tau according to h1(tau)/tau, where
9157 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9158 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9159 C...I1/I5*c5*1/(tau+tau_R') +
9160 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9161 C...I1/I7*c7*tau/(1.-tau), and
9162 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9163 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9165 IF(MINT(51).NE.0) THEN
9166 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9175 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9176 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9177 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9178 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9180 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9181 & COEF(ISUB,5)) MTAU=6
9182 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9183 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9184 CALL PYKMAP(1,MTAU,PYR(0))
9186 C...2 -> 3, 4 processes:
9187 C...Choose tau' according to h4(tau,tau')/tau', where
9188 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9189 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9190 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9192 IF(MINT(51).NE.0) THEN
9193 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9202 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9203 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9204 CALL PYKMAP(4,MTAUP,PYR(0))
9207 C...Choose y* according to h2(y*), where
9208 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9209 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9210 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9211 C...and c1 + c2 + c3 + c4 + c5 = 1.
9213 IF(MINT(51).NE.0) THEN
9214 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9223 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9224 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9225 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9226 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9227 & COEF(ISUB,11)) MYST=5
9228 CALL PYKMAP(2,MYST,PYR(0))
9230 C...2 -> 2 processes:
9231 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9232 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9233 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9234 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9235 C...and c0 + c1 + c2 + c3 + c4 = 1.
9237 IF(MINT(51).NE.0) THEN
9238 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9245 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9248 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9249 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9250 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9251 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9252 & COEF(ISUB,16)) MCTH=5
9253 CALL PYKMAP(3,MCTH,PYR(0))
9256 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9258 CALL PYKMAP(5,0,0D0)
9259 IF(MINT(51).NE.0) THEN
9260 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9269 C...DIS as f + gamma* -> f process: set dummy values.
9270 ELSEIF(ISTSB.EQ.8) THEN
9277 C...Low-pT or multiple interactions (first semihard interaction).
9278 ELSEIF(ISTSB.EQ.9) THEN
9279 IF(MINT(35).LE.1) CALL PYMULT(3)
9280 IF(MINT(35).GE.2) CALL PYMIGN(3)
9283 C...Study user-defined process: kinematics plus weight.
9284 ELSEIF(ISTSB.EQ.11) THEN
9285 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9286 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9291 IF(MINT(82).EQ.1) THEN
9292 NGEN(0,1)=NGEN(0,1)-1
9293 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9295 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9299 C...Extract cross section event weight.
9300 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9303 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9305 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9306 VINT(97)=SIGN(1D0,XWGTUP)
9308 VINT(97)=1D-9*XWGTUP
9311 C...Construct 'trivial' kinematical variables needed.
9314 VINT(41)=PUP(4,1)/EBMUP(1)
9315 VINT(42)=PUP(4,2)/EBMUP(2)
9316 VINT(21)=VINT(41)*VINT(42)
9317 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9318 VINT(44)=VINT(21)*VINT(2)
9319 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9321 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9322 VINT(56)=VINT(55)**2
9326 C...Construct other kinematical variables needed (approximately).
9329 VINT(45)=-0.5D0*VINT(44)
9330 VINT(46)=-0.5D0*VINT(44)
9339 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9340 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9342 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9343 & '(PYRAND:) unacceptable ISTUP code for particles')
9344 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9345 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9346 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9349 VINT(47)=SQRT(VINT(48))
9352 C...Choose azimuthal angle.
9354 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9356 C...Check against user cuts on kinematics at parton level.
9358 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9359 IF(MINT(51).NE.0) THEN
9360 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9367 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9369 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9372 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9381 C...Calculate differential cross-section for different subprocesses.
9382 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9384 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9386 C...Multiply cross section by lepton -> photon flux factor.
9387 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9390 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9392 SIGLPT=WTGAGA*SIGLPT
9395 C...Multiply cross-section by user-defined weights.
9396 IF(MSTP(173).EQ.1) THEN
9399 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9401 SIGLPT=PARP(173)*SIGLPT
9407 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9408 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9409 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9412 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9415 C...Calculations for Monte Carlo estimate of all cross-sections.
9416 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9417 IF(MSTP(142).LE.1) THEN
9418 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9420 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9422 ELSEIF(MINT(82).EQ.1) THEN
9423 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9425 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9426 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9428 C...Multiple interactions: store results of cross-section calculation.
9429 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9431 IF(MINT(35).LE.1) CALL PYMULT(4)
9432 IF(MINT(35).GE.2) CALL PYMIGN(4)
9435 C...Ratio of actual to maximum cross section.
9436 IF(ISTSB.NE.11) THEN
9437 VIOL=SIGSWT/XSEC(ISUB,1)
9438 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9439 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9440 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9441 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9442 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9447 C...Check that weight not negative.
9448 IF(MSTP(123).LE.0) THEN
9449 IF(VIOL.LT.-1D-3) THEN
9450 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9451 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9452 & VINT(22),VINT(23),VINT(26)
9456 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9458 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9459 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9460 & VINT(22),VINT(23),VINT(26)
9464 C...Weighting using estimate of maximum of differential cross-section.
9466 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9467 IF(VIOL.LT.PYR(0)) THEN
9468 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9469 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9472 ELSEIF(MFAIL.EQ.0) THEN
9473 RATND=SIGLPT/XSEC(95,1)
9475 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9476 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9477 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9478 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9482 IF(VIOL.LT.PYR(0)) THEN
9485 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9486 IF(VIOL.LT.PYR(0)) THEN
9488 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9492 RATND=SIGLPT/XSEC(95,1)
9493 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9495 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9499 IF(VIOL.LT.PYR(0)) THEN
9500 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9505 C...Check for possible violation of estimated maximum of differential
9506 C...cross-section used in weighting.
9507 IF(MSTP(123).LE.0) THEN
9508 IF(VIOL.GT.1D0) THEN
9509 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9510 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9511 & VINT(22),VINT(23),VINT(26)
9514 ELSEIF(MSTP(123).EQ.1) THEN
9515 IF(VIOL.GT.VINT(108)) THEN
9517 IF(VIOL.GT.1.0001D0) THEN
9519 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9520 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9521 & VINT(22),VINT(23),VINT(26)
9524 ELSEIF(VIOL.GT.VINT(108)) THEN
9526 IF(VIOL.GT.1D0) THEN
9528 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9529 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9531 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9532 IF(KFPR(ISUB,1).LE.9) THEN
9533 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9534 & XMAXUP(KFPR(ISUB,1))
9535 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9536 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9537 & XMAXUP(KFPR(ISUB,1))
9539 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9540 & XMAXUP(KFPR(ISUB,1))
9543 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9544 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9545 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9546 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9547 & XSEC(0,1)=XSEC(0,1)+XDIF
9548 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9549 & VINT(22),VINT(23),VINT(26)
9551 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9552 ELSEIF(ISUB.LE.99) THEN
9553 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9555 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9562 C...Multiple interactions: choose impact parameter (if not already done).
9563 IF(MINT(39).EQ.0) VINT(148)=1D0
9564 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9565 &MSTP(82).GE.3) THEN
9566 IF(MINT(35).LE.1) CALL PYMULT(5)
9567 IF(MINT(35).GE.2) CALL PYMIGN(5)
9568 IF(VINT(150).LT.PYR(0)) THEN
9569 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9577 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9578 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9579 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9580 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9582 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9584 C...Choose flavour of reacting partons (and subprocess).
9585 IF(ISTSB.GE.11) GOTO 320
9588 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9589 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9590 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9591 &PYR(0).GT.RQQBAR)) THEN
9595 MINT(2)=ISIG(ICHN,3)
9596 RSIGS=RSIGS-SIGH(ICHN)
9597 IF(RSIGS.LE.0D0) GOTO 320
9600 C...Multiple interactions: choose qqbar preferentially at small pT.
9601 ELSEIF(ISUB.EQ.96) THEN
9604 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9607 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9610 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
9612 C...Low-pT: choose string drawing configuration.
9618 IF(RSIGS.GT.1D0) MINT(2)=2
9619 IF(RSIGS.GT.2D0) MINT(2)=3
9622 C...Reassign QCD process. Partons before initial state radiation.
9623 320 IF(MINT(2).GT.10) THEN
9625 MINT(2)=MOD(MINT(2),10)
9627 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
9638 C...Calculate x value of photon for parton inside photon inside e.
9643 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
9644 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
9645 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
9650 MINT(105)=MINT(102+JT)
9651 MINT(109)=MINT(106+JT)
9652 VINT(120)=VINT(2+JT)
9653 IF(MSTP(57).LE.1) THEN
9654 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
9656 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
9659 IF(MSTP(13).EQ.2) THEN
9660 Q2PMS=Q2HRD/PMAS(11,1)**2
9661 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
9664 XG=MIN(1D0-1D-10,XHRD/XE)
9665 IF(MSTP(57).LE.1) THEN
9666 CALL PYPDFU(22,XG,Q2HRD,XPQ)
9668 CALL PYPDFL(22,XG,Q2HRD,XPQ)
9670 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
9671 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
9672 IF(WT.LT.PYR(0)*WTMX) GOTO 330
9676 XSFX(JT,KFLS)=XPQ(KFLS)
9681 C...Pick scale where photon is resolved.
9685 IF(MINT(107).EQ.3) THEN
9686 IF(MSTP(66).EQ.1) THEN
9687 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
9688 ELSEIF(MSTP(66).EQ.2) THEN
9690 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
9691 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
9692 Q2INT=SQRT(Q0S*Q2EFF)
9693 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
9694 ELSEIF(MSTP(66).EQ.3) THEN
9695 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
9696 ELSEIF(MSTP(66).GE.4) THEN
9697 PS=0.25D0*VINT(3)**2
9698 VINT(283)=(Q0S+PS)*(Q1S+PS)/
9699 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9703 IF(MINT(108).EQ.3) THEN
9704 IF(MSTP(66).EQ.1) THEN
9705 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
9706 ELSEIF(MSTP(66).EQ.2) THEN
9708 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
9709 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
9710 Q2INT=SQRT(Q0S*Q2EFF)
9711 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
9712 ELSEIF(MSTP(66).EQ.3) THEN
9713 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
9714 ELSEIF(MSTP(66).GE.4) THEN
9715 PS=0.25D0*VINT(4)**2
9716 VINT(284)=(Q0S+PS)*(Q1S+PS)/
9717 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9720 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9722 C...Format statements for differential cross-section maximum violations.
9723 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
9724 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
9725 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
9726 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
9727 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
9729 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
9730 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
9731 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
9733 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
9734 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
9735 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
9736 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
9737 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
9738 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
9743 C*********************************************************************
9746 C...Finds outgoing flavours and event type; sets up the kinematics
9747 C...and colour flow of the hard scattering
9751 C...Double precision and integer declarations
9752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9753 IMPLICIT INTEGER(I-N)
9754 INTEGER PYK,PYCHGE,PYCOMP
9755 C...Parameter statement to help give large particle numbers.
9756 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9757 &KEXCIT=4000000,KDIMEN=5000000)
9758 C...Parameter statement for maximum size of showers.
9759 PARAMETER (MAXNUR=1000)
9761 C...User process event common block.
9763 PARAMETER (MAXNUP=500)
9764 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9765 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9766 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9767 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9768 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9772 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
9773 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9776 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9777 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9778 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9779 COMMON/PYINT1/MINT(400),VINT(400)
9780 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9781 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9782 COMMON/PYINT4/MWID(500),WIDS(500,5)
9783 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9784 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
9785 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
9786 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
9787 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
9788 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
9790 C...Local arrays and saved variables
9791 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
9792 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
9795 C...Read out process
9799 C...Restore information for low-pT processes
9800 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
9802 100 VINT(J)=VINTSV(J)
9805 C...Convert H' or A process into equivalent H one
9808 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
9811 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
9813 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
9814 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
9815 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
9816 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
9817 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
9818 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
9819 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
9820 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
9821 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
9822 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
9823 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
9824 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
9827 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
9829 C...Convert bottomonium process into equivalent charmonium ones.
9830 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
9832 C...Choice of subprocess, number of documentation lines
9834 IF(ISUB.EQ.95) IDOC=8
9835 IF(ISET(ISUB).EQ.5) IDOC=9
9836 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
9838 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
9847 C...Reset K, P and V vectors. Store incoming particles
9848 DO 120 JT=1,MSTP(126)+100
9850 IF(I.GT.MSTU(4)) GOTO 120
9862 P(I,J)=VINT(285+5*JT+J)
9868 C...Store incoming partons in their CM-frame. Save pdf value.
9871 SHP=VINT(26)*VINT(2)
9874 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
9879 K(I,3)=MINT(83)+2+JT
9880 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
9882 VINT(38+JT)=XSFX(JT,MINT(14+JT))
9885 C...Copy incoming partons to documentation lines
9897 C...Choose new quark/lepton flavour for relevant annihilation graphs
9898 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
9899 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
9901 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
9902 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
9903 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
9904 DO 190 I=1,MDCY(IGLGA,3)
9905 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
9906 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
9907 IF(RKFL.LE.0D0) GOTO 200
9910 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
9911 IF(KFLF.GE.4) GOTO 180
9912 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
9915 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
9918 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
9919 & .AND.IABS(KFLF).GE.3) THEN
9920 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
9922 FACCIB=VINT(46)**2/RTCM(41)**4
9923 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
9924 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
9927 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
9928 IF(KFLF.EQ.5) GOTO 180
9929 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9930 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
9931 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
9932 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
9936 C...Final state flavours and colour flow: default values
9943 KCS=ISIGN(1,MINT(15))
9945 IF(ISET(ISUB).EQ.11) THEN
9946 C...User-defined processes: find products
9949 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
9950 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
9951 MINT(21+IUP)=IDUP(IUP)
9952 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
9953 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
9954 ELSEIF(IDUP(IUP).EQ.0) THEN
9957 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
9961 ELSEIF(ISUB.LE.10) THEN
9963 C...f + fbar -> gamma*/Z0
9966 ELSEIF(ISUB.EQ.2) THEN
9967 C...f + fbar' -> W+/-
9968 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9969 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9970 KFRES=ISIGN(24,KCH1+KCH2)
9972 ELSEIF(ISUB.EQ.3) THEN
9973 C...f + fbar -> h0 (or H0, or A0)
9976 ELSEIF(ISUB.EQ.4) THEN
9977 C...gamma + W+/- -> W+/-
9979 ELSEIF(ISUB.EQ.5) THEN
9984 PMQ(1)=PYMASS(MINT(21))
9985 PMQ(2)=PYMASS(MINT(22))
9986 220 JT=INT(1.5D0+PYR(0))
9987 ZMIN=2D0*PMQ(JT)/SHPR
9988 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9989 & (SHPR*(SHPR-PMQ(3-JT)))
9990 ZMAX=MIN(1D0-XH,ZMAX)
9991 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9992 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9993 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
9994 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9995 IF(SQC1.LT.1D-8) GOTO 220
9997 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9998 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9999 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10000 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10001 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10002 IF(SQC1.LT.1D-8) GOTO 220
10004 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10005 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10006 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10007 PHIR=PARU(2)*PYR(0)
10009 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10010 & SQRT(1D0-CTHE(2)**2)*CPHI
10012 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10013 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10014 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10015 & PMQ(3-JT)**2/SHP))
10016 ZMIN=2D0*PMQ(3-JT)/SHPR
10017 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10018 ZMAX=MIN(1D0-XH,ZMAX)
10019 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10023 ELSEIF(ISUB.EQ.6) THEN
10024 C...Z0 + W+/- -> W+/-
10026 ELSEIF(ISUB.EQ.7) THEN
10029 ELSEIF(ISUB.EQ.8) THEN
10036 RVCKM=VINT(180+I)*PYR(0)
10039 IPM=(5-ISIGN(1,I))/2
10041 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10042 MINT(20+JT)=ISIGN(IB,I)
10043 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10044 IF(RVCKM.LE.0D0) GOTO 250
10047 IB=2*((IA+1)/2)-1+MOD(IA,2)
10048 MINT(20+JT)=ISIGN(IB,I)
10050 250 PMQ(JT)=PYMASS(MINT(20+JT))
10052 JT=INT(1.5D0+PYR(0))
10053 ZMIN=2D0*PMQ(JT)/SHPR
10054 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10055 & (SHPR*(SHPR-PMQ(3-JT)))
10056 ZMAX=MIN(1D0-XH,ZMAX)
10057 IF(ZMIN.GE.ZMAX) GOTO 230
10058 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10059 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10060 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10061 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10062 IF(SQC1.LT.1D-8) GOTO 230
10064 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10065 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10066 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10067 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10068 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10069 IF(SQC1.LT.1D-8) GOTO 230
10071 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10072 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10073 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10074 PHIR=PARU(2)*PYR(0)
10076 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10077 & SQRT(1D0-CTHE(2)**2)*CPHI
10079 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10080 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10081 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10082 & PMQ(3-JT)**2/SHP))
10083 ZMIN=2D0*PMQ(3-JT)/SHPR
10084 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10085 ZMAX=MIN(1D0-XH,ZMAX)
10086 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10090 ELSEIF(ISUB.EQ.10) THEN
10091 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10092 IF(MINT(2).EQ.1) THEN
10095 C...W exchange: need to mix flavours according to CKM matrix
10100 RVCKM=VINT(180+I)*PYR(0)
10103 IPM=(5-ISIGN(1,I))/2
10105 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10106 MINT(20+JT)=ISIGN(IB,I)
10107 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10108 IF(RVCKM.LE.0D0) GOTO 280
10111 IB=2*((IA+1)/2)-1+MOD(IA,2)
10112 MINT(20+JT)=ISIGN(IB,I)
10119 ELSEIF(ISUB.LE.20) THEN
10120 IF(ISUB.EQ.11) THEN
10121 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10123 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10125 ELSEIF(ISUB.EQ.12) THEN
10126 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10127 MINT(21)=ISIGN(KFLF,MINT(15))
10131 ELSEIF(ISUB.EQ.13) THEN
10132 C...f + fbar -> g + g; th arbitrary
10137 ELSEIF(ISUB.EQ.14) THEN
10138 C...f + fbar -> g + gamma; th arbitrary
10139 IF(PYR(0).GT.0.5D0) JS=2
10144 ELSEIF(ISUB.EQ.15) THEN
10145 C...f + fbar -> g + Z0; th arbitrary
10146 IF(PYR(0).GT.0.5D0) JS=2
10151 ELSEIF(ISUB.EQ.16) THEN
10152 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10153 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10154 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10155 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10157 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10160 ELSEIF(ISUB.EQ.17) THEN
10161 C...f + fbar -> g + h0; th arbitrary
10162 IF(PYR(0).GT.0.5D0) JS=2
10167 ELSEIF(ISUB.EQ.18) THEN
10168 C...f + fbar -> gamma + gamma; th arbitrary
10172 ELSEIF(ISUB.EQ.19) THEN
10173 C...f + fbar -> gamma + Z0; th arbitrary
10174 IF(PYR(0).GT.0.5D0) JS=2
10178 ELSEIF(ISUB.EQ.20) THEN
10179 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10180 C...(p(fbar')-p(W+))**2
10181 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10182 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10183 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10185 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10188 ELSEIF(ISUB.LE.30) THEN
10189 IF(ISUB.EQ.21) THEN
10190 C...f + fbar -> gamma + h0; th arbitrary
10191 IF(PYR(0).GT.0.5D0) JS=2
10195 ELSEIF(ISUB.EQ.22) THEN
10196 C...f + fbar -> Z0 + Z0; th arbitrary
10200 ELSEIF(ISUB.EQ.23) THEN
10201 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10202 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10203 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10204 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10206 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10208 ELSEIF(ISUB.EQ.24) THEN
10209 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10210 IF(PYR(0).GT.0.5D0) JS=2
10214 ELSEIF(ISUB.EQ.25) THEN
10215 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10216 MINT(21)=-ISIGN(24,MINT(15))
10219 ELSEIF(ISUB.EQ.26) THEN
10220 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10221 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10222 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10223 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10224 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10225 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10228 ELSEIF(ISUB.EQ.27) THEN
10229 C...f + fbar -> h0 + h0
10231 ELSEIF(ISUB.EQ.28) THEN
10232 C...f + g -> f + g; th = (p(f)-p(f))**2
10233 IF(MINT(15).EQ.21) JS=2
10235 IF(MINT(15).EQ.21) KCC=KCC+2
10236 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10237 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10239 ELSEIF(ISUB.EQ.29) THEN
10240 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10241 IF(MINT(15).EQ.21) JS=2
10244 KCS=ISIGN(1,MINT(14+JS))
10246 ELSEIF(ISUB.EQ.30) THEN
10247 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10248 IF(MINT(15).EQ.21) JS=2
10251 KCS=ISIGN(1,MINT(14+JS))
10254 ELSEIF(ISUB.LE.40) THEN
10255 IF(ISUB.EQ.31) THEN
10256 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10257 IF(MINT(15).EQ.21) JS=2
10260 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10261 RVCKM=VINT(180+I)*PYR(0)
10264 IPM=(5-ISIGN(1,I))/2
10266 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10267 MINT(20+JS)=ISIGN(IB,I)
10268 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10269 IF(RVCKM.LE.0D0) GOTO 300
10272 KCS=ISIGN(1,MINT(14+JS))
10274 ELSEIF(ISUB.EQ.32) THEN
10275 C...f + g -> f + h0; th = (p(f)-p(f))**2
10276 IF(MINT(15).EQ.21) JS=2
10279 KCS=ISIGN(1,MINT(14+JS))
10281 ELSEIF(ISUB.EQ.33) THEN
10282 C...f + gamma -> f + g; th=(p(f)-p(f))**2
10283 IF(MINT(15).EQ.22) JS=2
10286 KCS=ISIGN(1,MINT(14+JS))
10288 ELSEIF(ISUB.EQ.34) THEN
10289 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10290 IF(MINT(15).EQ.22) JS=2
10292 KCS=ISIGN(1,MINT(14+JS))
10294 ELSEIF(ISUB.EQ.35) THEN
10295 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10296 IF(MINT(15).EQ.22) JS=2
10300 ELSEIF(ISUB.EQ.36) THEN
10301 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10302 IF(MINT(15).EQ.22) JS=2
10305 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10307 RVCKM=VINT(180+I)*PYR(0)
10310 IPM=(5-ISIGN(1,I))/2
10312 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10313 MINT(20+JS)=ISIGN(IB,I)
10314 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10315 IF(RVCKM.LE.0D0) GOTO 320
10318 IB=2*((IA+1)/2)-1+MOD(IA,2)
10319 MINT(20+JS)=ISIGN(IB,I)
10323 ELSEIF(ISUB.EQ.37) THEN
10324 C...f + gamma -> f + h0
10326 ELSEIF(ISUB.EQ.38) THEN
10327 C...f + Z0 -> f + g
10329 ELSEIF(ISUB.EQ.39) THEN
10330 C...f + Z0 -> f + gamma
10332 ELSEIF(ISUB.EQ.40) THEN
10333 C...f + Z0 -> f + Z0
10336 ELSEIF(ISUB.LE.50) THEN
10337 IF(ISUB.EQ.41) THEN
10338 C...f + Z0 -> f' + W+/-
10340 ELSEIF(ISUB.EQ.42) THEN
10341 C...f + Z0 -> f + h0
10343 ELSEIF(ISUB.EQ.43) THEN
10344 C...f + W+/- -> f' + g
10346 ELSEIF(ISUB.EQ.44) THEN
10347 C...f + W+/- -> f' + gamma
10349 ELSEIF(ISUB.EQ.45) THEN
10350 C...f + W+/- -> f' + Z0
10352 ELSEIF(ISUB.EQ.46) THEN
10353 C...f + W+/- -> f' + W+/-
10355 ELSEIF(ISUB.EQ.47) THEN
10356 C...f + W+/- -> f' + h0
10358 ELSEIF(ISUB.EQ.48) THEN
10359 C...f + h0 -> f + g
10361 ELSEIF(ISUB.EQ.49) THEN
10362 C...f + h0 -> f + gamma
10364 ELSEIF(ISUB.EQ.50) THEN
10365 C...f + h0 -> f + Z0
10368 ELSEIF(ISUB.LE.60) THEN
10369 IF(ISUB.EQ.51) THEN
10370 C...f + h0 -> f' + W+/-
10372 ELSEIF(ISUB.EQ.52) THEN
10373 C...f + h0 -> f + h0
10375 ELSEIF(ISUB.EQ.53) THEN
10376 C...g + g -> f + fbar; th arbitrary
10377 KCS=(-1)**INT(1.5D0+PYR(0))
10378 MINT(21)=ISIGN(KFLF,KCS)
10382 ELSEIF(ISUB.EQ.54) THEN
10383 C...g + gamma -> f + fbar; th arbitrary
10384 KCS=(-1)**INT(1.5D0+PYR(0))
10385 MINT(21)=ISIGN(KFLF,KCS)
10388 IF(MINT(16).EQ.21) KCC=28
10390 ELSEIF(ISUB.EQ.55) THEN
10391 C...g + Z0 -> f + fbar
10393 ELSEIF(ISUB.EQ.56) THEN
10394 C...g + W+/- -> f + fbar'
10396 ELSEIF(ISUB.EQ.57) THEN
10397 C...g + h0 -> f + fbar
10399 ELSEIF(ISUB.EQ.58) THEN
10400 C...gamma + gamma -> f + fbar; th arbitrary
10401 KCS=(-1)**INT(1.5D0+PYR(0))
10402 MINT(21)=ISIGN(KFLF,KCS)
10406 ELSEIF(ISUB.EQ.59) THEN
10407 C...gamma + Z0 -> f + fbar
10409 ELSEIF(ISUB.EQ.60) THEN
10410 C...gamma + W+/- -> f + fbar'
10413 ELSEIF(ISUB.LE.70) THEN
10414 IF(ISUB.EQ.61) THEN
10415 C...gamma + h0 -> f + fbar
10417 ELSEIF(ISUB.EQ.62) THEN
10418 C...Z0 + Z0 -> f + fbar
10420 ELSEIF(ISUB.EQ.63) THEN
10421 C...Z0 + W+/- -> f + fbar'
10423 ELSEIF(ISUB.EQ.64) THEN
10424 C...Z0 + h0 -> f + fbar
10426 ELSEIF(ISUB.EQ.65) THEN
10427 C...W+ + W- -> f + fbar
10429 ELSEIF(ISUB.EQ.66) THEN
10430 C...W+/- + h0 -> f + fbar'
10432 ELSEIF(ISUB.EQ.67) THEN
10433 C...h0 + h0 -> f + fbar
10435 ELSEIF(ISUB.EQ.68) THEN
10436 C...g + g -> g + g; th arbitrary
10438 KCS=(-1)**INT(1.5D0+PYR(0))
10440 ELSEIF(ISUB.EQ.69) THEN
10441 C...gamma + gamma -> W+ + W-; th arbitrary
10446 ELSEIF(ISUB.EQ.70) THEN
10447 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10448 IF(MINT(15).EQ.22) MINT(21)=23
10449 IF(MINT(16).EQ.22) MINT(22)=23
10453 ELSEIF(ISUB.LE.80) THEN
10454 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10455 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10459 PMQ(1)=PYMASS(MINT(21))
10460 PMQ(2)=PYMASS(MINT(22))
10461 330 JT=INT(1.5D0+PYR(0))
10462 ZMIN=2D0*PMQ(JT)/SHPR
10463 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10464 & (SHPR*(SHPR-PMQ(3-JT)))
10465 ZMAX=MIN(1D0-XH,ZMAX)
10466 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10467 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10468 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10469 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10470 IF(SQC1.LT.1D-8) GOTO 330
10472 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10473 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10474 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10475 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10476 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10477 IF(SQC1.LT.1D-8) GOTO 330
10479 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10480 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10481 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10482 PHIR=PARU(2)*PYR(0)
10484 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10485 & SQRT(1D0-CTHE(2)**2)*CPHI
10487 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10488 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10489 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10490 & PMQ(3-JT)**2/SHP))
10491 ZMIN=2D0*PMQ(3-JT)/SHPR
10492 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10493 ZMAX=MIN(1D0-XH,ZMAX)
10494 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10497 ELSEIF(ISUB.EQ.73) THEN
10498 C...Z0 + W+/- -> Z0 + W+/-
10505 RVCKM=VINT(180+I)*PYR(0)
10508 IPM=(5-ISIGN(1,I))/2
10510 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10511 MINT(20+JT)=ISIGN(IB,I)
10512 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10513 IF(RVCKM.LE.0D0) GOTO 360
10516 IB=2*((IA+1)/2)-1+MOD(IA,2)
10517 MINT(20+JT)=ISIGN(IB,I)
10519 360 PMQ(JT)=PYMASS(MINT(20+JT))
10520 MINT(23-JT)=MINT(17-JT)
10521 PMQ(3-JT)=PYMASS(MINT(23-JT))
10522 JT=INT(1.5D0+PYR(0))
10523 ZMIN=2D0*PMQ(JT)/SHPR
10524 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10525 & (SHPR*(SHPR-PMQ(3-JT)))
10526 ZMAX=MIN(1D0-XH,ZMAX)
10527 IF(ZMIN.GE.ZMAX) GOTO 340
10528 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10529 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10530 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10531 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10532 IF(SQC1.LT.1D-8) GOTO 340
10534 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10535 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10536 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10537 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10538 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10539 IF(SQC1.LT.1D-8) GOTO 340
10541 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10542 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10543 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10544 PHIR=PARU(2)*PYR(0)
10546 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10547 & SQRT(1D0-CTHE(2)**2)*CPHI
10549 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10550 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10551 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10552 & PMQ(3-JT)**2/SHP))
10553 ZMIN=2D0*PMQ(3-JT)/SHPR
10554 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10555 ZMAX=MIN(1D0-XH,ZMAX)
10556 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10559 ELSEIF(ISUB.EQ.74) THEN
10560 C...Z0 + h0 -> Z0 + h0
10562 ELSEIF(ISUB.EQ.75) THEN
10563 C...W+ + W- -> gamma + gamma
10565 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10566 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10572 RVCKM=VINT(180+I)*PYR(0)
10575 IPM=(5-ISIGN(1,I))/2
10577 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10578 MINT(20+JT)=ISIGN(IB,I)
10579 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10580 IF(RVCKM.LE.0D0) GOTO 390
10583 IB=2*((IA+1)/2)-1+MOD(IA,2)
10584 MINT(20+JT)=ISIGN(IB,I)
10586 390 PMQ(JT)=PYMASS(MINT(20+JT))
10588 JT=INT(1.5D0+PYR(0))
10589 ZMIN=2D0*PMQ(JT)/SHPR
10590 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10591 & (SHPR*(SHPR-PMQ(3-JT)))
10592 ZMAX=MIN(1D0-XH,ZMAX)
10593 IF(ZMIN.GE.ZMAX) GOTO 370
10594 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10595 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10596 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10597 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10598 IF(SQC1.LT.1D-8) GOTO 370
10600 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10601 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10602 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10603 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10604 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10605 IF(SQC1.LT.1D-8) GOTO 370
10607 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10608 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10609 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10610 PHIR=PARU(2)*PYR(0)
10612 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10613 & SQRT(1D0-CTHE(2)**2)*CPHI
10615 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10616 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10617 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10618 & PMQ(3-JT)**2/SHP))
10619 ZMIN=2D0*PMQ(3-JT)/SHPR
10620 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10621 ZMAX=MIN(1D0-XH,ZMAX)
10622 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
10625 ELSEIF(ISUB.EQ.78) THEN
10626 C...W+/- + h0 -> W+/- + h0
10628 ELSEIF(ISUB.EQ.79) THEN
10629 C...h0 + h0 -> h0 + h0
10631 ELSEIF(ISUB.EQ.80) THEN
10632 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
10633 IF(MINT(15).EQ.22) JS=2
10636 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
10638 MINT(20+JS)=ISIGN(IB,I)
10642 ELSEIF(ISUB.LE.90) THEN
10643 IF(ISUB.EQ.81) THEN
10644 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
10645 MINT(21)=ISIGN(MINT(55),MINT(15))
10649 ELSEIF(ISUB.EQ.82) THEN
10650 C...g + g -> Q + Qbar; th arbitrary
10651 KCS=(-1)**INT(1.5D0+PYR(0))
10652 MINT(21)=ISIGN(MINT(55),KCS)
10656 ELSEIF(ISUB.EQ.83) THEN
10657 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
10659 IF(MINT(2).EQ.2) KFOLD=MINT(15)
10661 IF(KFAOLD.GT.10) THEN
10662 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
10664 RCKM=VINT(180+KFOLD)*PYR(0)
10665 IPM=(5-ISIGN(1,KFOLD))/2
10666 KFANEW=-MOD(KFAOLD+1,2)
10667 410 KFANEW=KFANEW+2
10668 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
10669 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
10670 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
10671 & VCKM(KFAOLD/2,(KFANEW+1)/2)
10672 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
10673 & VCKM(KFANEW/2,(KFAOLD+1)/2)
10675 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
10677 IF(MINT(2).EQ.1) THEN
10678 MINT(21)=ISIGN(MINT(55),MINT(15))
10679 MINT(22)=ISIGN(KFANEW,MINT(16))
10681 MINT(21)=ISIGN(KFANEW,MINT(15))
10682 MINT(22)=ISIGN(MINT(55),MINT(16))
10687 ELSEIF(ISUB.EQ.84) THEN
10688 C...g + gamma -> Q + Qbar; th arbitary
10689 KCS=(-1)**INT(1.5D0+PYR(0))
10690 MINT(21)=ISIGN(MINT(55),KCS)
10693 IF(MINT(16).EQ.21) KCC=28
10695 ELSEIF(ISUB.EQ.85) THEN
10696 C...gamma + gamma -> F + Fbar; th arbitary
10697 KCS=(-1)**INT(1.5D0+PYR(0))
10698 MINT(21)=ISIGN(MINT(56),KCS)
10702 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
10703 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
10704 MINT(21)=KFPR(ISUB,1)
10705 MINT(22)=KFPR(ISUB,2)
10707 KCS=(-1)**INT(1.5D0+PYR(0))
10710 ELSEIF(ISUB.LE.100) THEN
10711 IF(ISUB.EQ.95) THEN
10712 C...Low-pT ( = energyless g + g -> g + g)
10714 KCS=(-1)**INT(1.5D0+PYR(0))
10716 ELSEIF(ISUB.EQ.96) THEN
10717 C...Multiple interactions (should be reassigned to QCD process)
10720 ELSEIF(ISUB.LE.110) THEN
10721 IF(ISUB.EQ.101) THEN
10722 C...g + g -> gamma*/Z0
10726 ELSEIF(ISUB.EQ.102) THEN
10727 C...g + g -> h0 (or H0, or A0)
10731 ELSEIF(ISUB.EQ.103) THEN
10732 C...gamma + gamma -> h0 (or H0, or A0)
10736 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
10737 C...g + g -> chi_0c or chi_2c.
10741 ELSEIF(ISUB.EQ.106) THEN
10742 C...g + g -> J/Psi + gamma
10743 MINT(21)=KFPR(ISUB,1)
10744 MINT(22)=KFPR(ISUB,2)
10747 ELSEIF(ISUB.EQ.107) THEN
10748 C...g + gamma -> J/Psi + g
10749 MINT(21)=KFPR(ISUB,1)
10750 MINT(22)=KFPR(ISUB,2)
10752 IF(MINT(16).EQ.22) KCC=33
10754 ELSEIF(ISUB.EQ.108) THEN
10755 C...gamma + gamma -> J/Psi + gamma
10756 MINT(21)=KFPR(ISUB,1)
10757 MINT(22)=KFPR(ISUB,2)
10759 ELSEIF(ISUB.EQ.110) THEN
10760 C...f + fbar -> gamma + h0; th arbitrary
10761 IF(PYR(0).GT.0.5D0) JS=2
10766 ELSEIF(ISUB.LE.120) THEN
10767 IF(ISUB.EQ.111) THEN
10768 C...f + fbar -> g + h0; th arbitrary
10769 IF(PYR(0).GT.0.5D0) JS=2
10774 ELSEIF(ISUB.EQ.112) THEN
10775 C...f + g -> f + h0; th = (p(f) - p(f))**2
10776 IF(MINT(15).EQ.21) JS=2
10779 KCS=ISIGN(1,MINT(14+JS))
10781 ELSEIF(ISUB.EQ.113) THEN
10782 C...g + g -> g + h0; th arbitrary
10783 IF(PYR(0).GT.0.5D0) JS=2
10786 KCS=(-1)**INT(1.5D0+PYR(0))
10788 ELSEIF(ISUB.EQ.114) THEN
10789 C...g + g -> gamma + gamma; th arbitrary
10790 IF(PYR(0).GT.0.5D0) JS=2
10795 ELSEIF(ISUB.EQ.115) THEN
10796 C...g + g -> g + gamma; th arbitrary
10797 IF(PYR(0).GT.0.5D0) JS=2
10800 KCS=(-1)**INT(1.5D0+PYR(0))
10802 ELSEIF(ISUB.EQ.116) THEN
10803 C...g + g -> gamma + Z0
10805 ELSEIF(ISUB.EQ.117) THEN
10806 C...g + g -> Z0 + Z0
10808 ELSEIF(ISUB.EQ.118) THEN
10809 C...g + g -> W+ + W-
10812 ELSEIF(ISUB.LE.140) THEN
10813 IF(ISUB.EQ.121) THEN
10814 C...g + g -> Q + Qbar + h0
10815 KCS=(-1)**INT(1.5D0+PYR(0))
10816 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
10818 KCC=11+INT(0.5D0+PYR(0))
10821 ELSEIF(ISUB.EQ.122) THEN
10822 C...q + qbar -> Q + Qbar + h0
10823 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
10828 ELSEIF(ISUB.EQ.123) THEN
10829 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
10834 ELSEIF(ISUB.EQ.124) THEN
10835 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
10841 RVCKM=VINT(180+I)*PYR(0)
10844 IPM=(5-ISIGN(1,I))/2
10846 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
10847 MINT(20+JT)=ISIGN(IB,I)
10848 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10849 IF(RVCKM.LE.0D0) GOTO 430
10852 IB=2*((IA+1)/2)-1+MOD(IA,2)
10853 MINT(20+JT)=ISIGN(IB,I)
10859 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
10860 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
10861 IF(MINT(15).EQ.22) JS=2
10864 KCS=ISIGN(1,MINT(14+JS))
10866 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
10867 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
10868 IF(MINT(15).EQ.22) JS=2
10870 KCS=ISIGN(1,MINT(14+JS))
10872 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10873 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
10874 KCS=(-1)**INT(1.5D0+PYR(0))
10875 MINT(21)=ISIGN(KFLF,KCS)
10878 IF(MINT(16).EQ.21) KCC=28
10880 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
10881 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
10882 KCS=(-1)**INT(1.5D0+PYR(0))
10883 MINT(21)=ISIGN(KFLF,KCS)
10889 ELSEIF(ISUB.LE.160) THEN
10890 IF(ISUB.EQ.141) THEN
10891 C...f + fbar -> gamma*/Z0/Z'0
10894 ELSEIF(ISUB.EQ.142) THEN
10895 C...f + fbar' -> W'+/-
10896 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10897 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10898 KFRES=ISIGN(34,KCH1+KCH2)
10900 ELSEIF(ISUB.EQ.143) THEN
10901 C...f + fbar' -> H+/-
10902 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10903 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10904 KFRES=ISIGN(37,KCH1+KCH2)
10906 ELSEIF(ISUB.EQ.144) THEN
10908 KFRES=ISIGN(41,MINT(15)+MINT(16))
10910 ELSEIF(ISUB.EQ.145) THEN
10911 C...q + l -> LQ (leptoquark)
10912 IF(IABS(MINT(16)).LE.8) JS=2
10913 KFRES=ISIGN(42,MINT(14+JS))
10915 KCS=ISIGN(1,MINT(14+JS))
10917 ELSEIF(ISUB.EQ.146) THEN
10918 C...e + gamma -> e* (excited lepton)
10919 IF(MINT(15).EQ.22) JS=2
10920 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
10923 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10924 C...q + g -> q* (excited quark)
10925 IF(MINT(15).EQ.21) JS=2
10926 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
10928 KCS=ISIGN(1,MINT(14+JS))
10930 ELSEIF(ISUB.EQ.149) THEN
10931 C...g + g -> eta_tc
10934 KCS=(-1)**INT(1.5D0+PYR(0))
10937 ELSEIF(ISUB.LE.200) THEN
10938 IF(ISUB.EQ.161) THEN
10939 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
10940 IF(MINT(15).EQ.21) JS=2
10943 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
10944 IB=IA+MOD(IA,2)-MOD(IA+1,2)
10945 MINT(20+JS)=ISIGN(IB,I)
10947 KCS=ISIGN(1,MINT(14+JS))
10949 ELSEIF(ISUB.EQ.162) THEN
10950 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
10951 IF(MINT(15).EQ.21) JS=2
10952 MINT(20+JS)=ISIGN(42,MINT(14+JS))
10953 KFLQL=KFDP(MDCY(42,2),2)
10954 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
10956 KCS=ISIGN(1,MINT(14+JS))
10958 ELSEIF(ISUB.EQ.163) THEN
10959 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
10960 KCS=(-1)**INT(1.5D0+PYR(0))
10961 MINT(21)=ISIGN(42,KCS)
10965 ELSEIF(ISUB.EQ.164) THEN
10966 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
10967 MINT(21)=ISIGN(42,MINT(15))
10971 ELSEIF(ISUB.EQ.165) THEN
10972 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
10973 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10976 ELSEIF(ISUB.EQ.166) THEN
10977 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
10978 IF(MOD(MINT(15),2).EQ.0) THEN
10979 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
10980 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
10982 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10983 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
10986 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
10987 C...q + q' -> q" + q* (excited quark)
10988 KFQSTR=KFPR(ISUB,2)
10989 KFQEXC=MOD(KFQSTR,KEXCIT)
10991 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
10992 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
10993 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
10997 ELSEIF(ISUB.EQ.169) THEN
10998 C...q + qbar -> e + e* (excited lepton)
10999 KFQSTR=KFPR(ISUB,2)
11000 KFQEXC=MOD(KFQSTR,KEXCIT)
11002 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11003 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11006 ELSEIF(ISUB.EQ.191) THEN
11007 C...f + fbar -> rho_tc0.
11010 ELSEIF(ISUB.EQ.192) THEN
11011 C...f + fbar' -> rho_tc+/-
11012 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11013 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11014 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11016 ELSEIF(ISUB.EQ.193) THEN
11017 C...f + fbar -> omega_tc0.
11020 ELSEIF(ISUB.EQ.194) THEN
11021 C...f + fbar -> f' + fbar' via mixture of s-channel
11022 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11023 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11026 ELSEIF(ISUB.EQ.195) THEN
11027 C...f + fbar' -> f'' + fbar''' via s-channel
11028 C...rho_tc+ th=(p(f)-p(f'))**2
11029 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11030 IF(MOD(MINT(15),2).EQ.0) THEN
11031 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11032 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11034 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11035 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11040 ELSEIF(ISUB.LE.215) THEN
11041 IF(ISUB.EQ.201) THEN
11042 C...f + fbar -> ~e_L + ~e_Lbar
11043 MINT(21)=ISIGN(KSUSY1+11,KCS)
11046 ELSEIF(ISUB.EQ.202) THEN
11047 C...f + fbar -> ~e_R + ~e_Rbar
11048 MINT(21)=ISIGN(KSUSY2+11,KCS)
11051 ELSEIF(ISUB.EQ.203) THEN
11052 C...f + fbar -> ~e_L + ~e_Rbar
11053 IF(MINT(15).LT.0) JS=2
11054 IF(MINT(2).EQ.1) THEN
11055 MINT(20+JS)=KFPR(ISUB,1)
11056 MINT(23-JS)=-KFPR(ISUB,2)
11058 MINT(20+JS)=-KFPR(ISUB,1)
11059 MINT(23-JS)=KFPR(ISUB,2)
11062 ELSEIF(ISUB.EQ.204) THEN
11063 C...f + fbar -> ~mu_L + ~mu_Lbar
11064 MINT(21)=ISIGN(KSUSY1+13,KCS)
11067 ELSEIF(ISUB.EQ.205) THEN
11068 C...f + fbar -> ~mu_R + ~mu_Rbar
11069 MINT(21)=ISIGN(KSUSY2+13,KCS)
11072 ELSEIF(ISUB.EQ.206) THEN
11073 C...f + fbar -> ~mu_L + ~mu_Rbar
11074 IF(MINT(15).LT.0) JS=2
11075 IF(MINT(2).EQ.1) THEN
11076 MINT(20+JS)=KFPR(ISUB,1)
11077 MINT(23-JS)=-KFPR(ISUB,2)
11079 MINT(20+JS)=-KFPR(ISUB,1)
11080 MINT(23-JS)=KFPR(ISUB,2)
11083 ELSEIF(ISUB.EQ.207) THEN
11084 C...f + fbar -> ~tau_1 + ~tau_1bar
11085 MINT(21)=ISIGN(KSUSY1+15,KCS)
11088 ELSEIF(ISUB.EQ.208) THEN
11089 C...f + fbar -> ~tau_2 + ~tau_2bar
11090 MINT(21)=ISIGN(KSUSY2+15,KCS)
11093 ELSEIF(ISUB.EQ.209) THEN
11094 C...f + fbar -> ~tau_1 + ~tau_2bar
11095 IF(MINT(15).LT.0) JS=2
11096 IF(MINT(2).EQ.1) THEN
11097 MINT(20+JS)=KFPR(ISUB,1)
11098 MINT(23-JS)=-KFPR(ISUB,2)
11100 MINT(20+JS)=-KFPR(ISUB,1)
11101 MINT(23-JS)=KFPR(ISUB,2)
11104 ELSEIF(ISUB.EQ.210) THEN
11105 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11106 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11107 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11108 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11109 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11111 ELSEIF(ISUB.EQ.211) THEN
11112 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11113 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11114 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11115 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11116 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11118 ELSEIF(ISUB.EQ.212) THEN
11119 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11120 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11121 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11122 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11123 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11125 ELSEIF(ISUB.EQ.213) THEN
11126 C...f + fbar -> ~nul + ~nulbar
11127 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11130 ELSEIF(ISUB.EQ.214) THEN
11131 C...f + fbar -> ~nutau + ~nutaubar
11132 MINT(21)=ISIGN(KSUSY1+16,KCS)
11136 ELSEIF(ISUB.LE.225) THEN
11137 IF(ISUB.EQ.216) THEN
11138 C...f + fbar -> ~chi01 + ~chi01
11142 ELSEIF(ISUB.EQ.217) THEN
11143 C...f + fbar -> ~chi02 + ~chi02
11147 ELSEIF(ISUB.EQ.218 ) THEN
11148 C...f + fbar -> ~chi03 + ~chi03
11152 ELSEIF(ISUB.EQ.219 ) THEN
11153 C...f + fbar -> ~chi04 + ~chi04
11157 ELSEIF(ISUB.EQ.220 ) THEN
11158 C...f + fbar -> ~chi01 + ~chi02
11159 IF(MINT(15).LT.0) JS=2
11160 C IF(PYR(0).GT.0.5D0) JS=2
11161 MINT(20+JS)=KSUSY1+22
11162 MINT(23-JS)=KSUSY1+23
11164 ELSEIF(ISUB.EQ.221 ) THEN
11165 C...f + fbar -> ~chi01 + ~chi03
11166 IF(MINT(15).LT.0) JS=2
11167 C IF(PYR(0).GT.0.5D0) JS=2
11168 MINT(20+JS)=KSUSY1+22
11169 MINT(23-JS)=KSUSY1+25
11171 ELSEIF(ISUB.EQ.222) THEN
11172 C...f + fbar -> ~chi01 + ~chi04
11173 IF(MINT(15).LT.0) JS=2
11174 C IF(PYR(0).GT.0.5D0) JS=2
11175 MINT(20+JS)=KSUSY1+22
11176 MINT(23-JS)=KSUSY1+35
11178 ELSEIF(ISUB.EQ.223) THEN
11179 C...f + fbar -> ~chi02 + ~chi03
11180 IF(MINT(15).LT.0) JS=2
11181 C IF(PYR(0).GT.0.5D0) JS=2
11182 MINT(20+JS)=KSUSY1+23
11183 MINT(23-JS)=KSUSY1+25
11185 ELSEIF(ISUB.EQ.224) THEN
11186 C...f + fbar -> ~chi02 + ~chi04
11187 IF(MINT(15).LT.0) JS=2
11188 C IF(PYR(0).GT.0.5D0) JS=2
11189 MINT(20+JS)=KSUSY1+23
11190 MINT(23-JS)=KSUSY1+35
11192 ELSEIF(ISUB.EQ.225) THEN
11193 C...f + fbar -> ~chi03 + ~chi04
11194 IF(MINT(15).LT.0) JS=2
11195 C IF(PYR(0).GT.0.5D0) JS=2
11196 MINT(20+JS)=KSUSY1+25
11197 MINT(23-JS)=KSUSY1+35
11200 ELSEIF(ISUB.LE.236) THEN
11201 IF(ISUB.EQ.226) THEN
11202 C...f + fbar -> ~chi+-1 + ~chi-+1
11203 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11204 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11205 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11208 ELSEIF(ISUB.EQ.227) THEN
11209 C...f + fbar -> ~chi+-2 + ~chi-+2
11210 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11211 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11214 ELSEIF(ISUB.EQ.228) THEN
11215 C...f + fbar -> ~chi+-1 + ~chi-+2
11216 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11217 C...js=1 if pyr<.5, js=2 if pyr>.5
11218 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11219 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11220 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11221 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11222 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11224 IF(MINT(2).EQ.1) THEN
11225 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11226 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11227 c IF(KCH2.EQ.0) JS=2
11229 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11230 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11232 c IF(KCH2.EQ.1) JS=2
11235 ELSEIF(ISUB.EQ.229) THEN
11236 C...q + qbar' -> ~chi01 + ~chi+-1
11237 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11238 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11239 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11241 IF(MOD(MINT(15),2).EQ.0) JS=2
11242 MINT(20+JS)=KSUSY1+22
11243 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11245 ELSEIF(ISUB.EQ.230) THEN
11246 C...q + qbar' -> ~chi02 + ~chi+-1
11247 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11248 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11249 IF(MOD(MINT(15),2).EQ.0) JS=2
11250 MINT(20+JS)=KSUSY1+23
11251 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11253 ELSEIF(ISUB.EQ.231) THEN
11254 C...q + qbar' -> ~chi03 + ~chi+-1
11255 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11256 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11257 IF(MOD(MINT(15),2).EQ.0) JS=2
11258 MINT(20+JS)=KSUSY1+25
11259 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11261 ELSEIF(ISUB.EQ.232) THEN
11262 C...q + qbar' -> ~chi04 + ~chi+-1
11263 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11264 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11265 IF(MOD(MINT(15),2).EQ.0) JS=2
11266 MINT(20+JS)=KSUSY1+35
11267 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11269 ELSEIF(ISUB.EQ.233) THEN
11270 C...q + qbar' -> ~chi01 + ~chi+-2
11271 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11272 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11273 IF(MOD(MINT(15),2).EQ.0) JS=2
11274 MINT(20+JS)=KSUSY1+22
11275 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11277 ELSEIF(ISUB.EQ.234) THEN
11278 C...q + qbar' -> ~chi02 + ~chi+-2
11279 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11280 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11281 IF(MOD(MINT(15),2).EQ.0) JS=2
11282 MINT(20+JS)=KSUSY1+23
11283 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11285 ELSEIF(ISUB.EQ.235) THEN
11286 C...q + qbar' -> ~chi03 + ~chi+-2
11287 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11288 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11289 IF(MOD(MINT(15),2).EQ.0) JS=2
11290 MINT(20+JS)=KSUSY1+25
11291 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11293 ELSEIF(ISUB.EQ.236) THEN
11294 C...q + qbar' -> ~chi04 + ~chi+-2
11295 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11296 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11297 IF(MOD(MINT(15),2).EQ.0) JS=2
11298 MINT(20+JS)=KSUSY1+35
11299 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11302 ELSEIF(ISUB.LE.245) THEN
11303 IF(ISUB.EQ.237) THEN
11304 C...q + qbar -> ~chi01 + ~g
11306 IF(PYR(0).GT.0.5D0) JS=2
11307 MINT(20+JS)=KSUSY1+21
11308 MINT(23-JS)=KSUSY1+22
11311 ELSEIF(ISUB.EQ.238) THEN
11312 C...q + qbar -> ~chi02 + ~g
11314 IF(PYR(0).GT.0.5D0) JS=2
11315 MINT(20+JS)=KSUSY1+21
11316 MINT(23-JS)=KSUSY1+23
11319 ELSEIF(ISUB.EQ.239) THEN
11320 C...q + qbar -> ~chi03 + ~g
11322 IF(PYR(0).GT.0.5D0) JS=2
11323 MINT(20+JS)=KSUSY1+21
11324 MINT(23-JS)=KSUSY1+25
11327 ELSEIF(ISUB.EQ.240) THEN
11328 C...q + qbar -> ~chi04 + ~g
11330 IF(PYR(0).GT.0.5D0) JS=2
11331 MINT(20+JS)=KSUSY1+21
11332 MINT(23-JS)=KSUSY1+35
11335 ELSEIF(ISUB.EQ.241) THEN
11336 C...q + qbar' -> ~chi+-1 + ~g
11337 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11338 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11339 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11340 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11341 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11342 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11343 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11345 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11346 MINT(20+JS)=KSUSY1+21
11347 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11350 ELSEIF(ISUB.EQ.242) THEN
11351 C...q + qbar' -> ~chi+-2 + ~g
11352 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11353 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11354 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11355 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11356 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11357 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11358 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11360 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11361 MINT(20+JS)=KSUSY1+21
11362 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11365 ELSEIF(ISUB.EQ.243) THEN
11366 C...q + qbar -> ~g + ~g ; th arbitrary
11371 ELSEIF(ISUB.EQ.244) THEN
11372 C...g + g -> ~g + ~g ; th arbitrary
11374 KCS=(-1)**INT(1.5D0+PYR(0))
11379 ELSEIF(ISUB.LE.260) THEN
11380 IF(ISUB.EQ.246) THEN
11381 C...qj + g -> ~qj_L + ~chi01
11382 IF(MINT(15).EQ.21) JS=2
11385 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11386 MINT(23-JS)=KSUSY1+22
11388 KCS=ISIGN(1,MINT(14+JS))
11390 ELSEIF(ISUB.EQ.247) THEN
11391 C...qj + g -> ~qj_R + ~chi01
11392 IF(MINT(15).EQ.21) JS=2
11395 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11396 MINT(23-JS)=KSUSY1+22
11398 KCS=ISIGN(1,MINT(14+JS))
11400 ELSEIF(ISUB.EQ.248) THEN
11401 C...qj + g -> ~qj_L + ~chi02
11402 IF(MINT(15).EQ.21) JS=2
11405 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11406 MINT(23-JS)=KSUSY1+23
11408 KCS=ISIGN(1,MINT(14+JS))
11410 ELSEIF(ISUB.EQ.249) THEN
11411 C...qj + g -> ~qj_R + ~chi02
11412 IF(MINT(15).EQ.21) JS=2
11415 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11416 MINT(23-JS)=KSUSY1+23
11418 KCS=ISIGN(1,MINT(14+JS))
11420 ELSEIF(ISUB.EQ.250) THEN
11421 C...qj + g -> ~qj_L + ~chi03
11422 IF(MINT(15).EQ.21) JS=2
11425 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11426 MINT(23-JS)=KSUSY1+25
11428 KCS=ISIGN(1,MINT(14+JS))
11430 ELSEIF(ISUB.EQ.251) THEN
11431 C...qj + g -> ~qj_R + ~chi03
11432 IF(MINT(15).EQ.21) JS=2
11435 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11436 MINT(23-JS)=KSUSY1+25
11438 KCS=ISIGN(1,MINT(14+JS))
11440 ELSEIF(ISUB.EQ.252) THEN
11441 C...qj + g -> ~qj_L + ~chi04
11442 IF(MINT(15).EQ.21) JS=2
11445 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11446 MINT(23-JS)=KSUSY1+35
11448 KCS=ISIGN(1,MINT(14+JS))
11450 ELSEIF(ISUB.EQ.253) THEN
11451 C...qj + g -> ~qj_R + ~chi04
11452 IF(MINT(15).EQ.21) JS=2
11455 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11456 MINT(23-JS)=KSUSY1+35
11458 KCS=ISIGN(1,MINT(14+JS))
11460 ELSEIF(ISUB.EQ.254) THEN
11461 C...qj + g -> ~qk_L + ~chi+-1
11462 IF(MINT(15).EQ.21) JS=2
11465 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11466 IB=-IA+INT((IA+1)/2)*4-1
11467 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11469 KCS=ISIGN(1,MINT(14+JS))
11471 ELSEIF(ISUB.EQ.255) THEN
11472 C...qj + g -> ~qk_L + ~chi+-1
11473 IF(MINT(15).EQ.21) JS=2
11476 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11477 IB=-IA+INT((IA+1)/2)*4-1
11478 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11480 KCS=ISIGN(1,MINT(14+JS))
11482 ELSEIF(ISUB.EQ.256) THEN
11483 C...qj + g -> ~qk_L + ~chi+-2
11484 IF(MINT(15).EQ.21) JS=2
11487 IB=-IA+INT((IA+1)/2)*4-1
11488 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11489 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11491 KCS=ISIGN(1,MINT(14+JS))
11493 ELSEIF(ISUB.EQ.257) THEN
11494 C...qj + g -> ~qk_R + ~chi+-2
11495 IF(MINT(15).EQ.21) JS=2
11498 IB=-IA+INT((IA+1)/2)*4-1
11499 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11500 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11502 KCS=ISIGN(1,MINT(14+JS))
11504 ELSEIF(ISUB.EQ.258) THEN
11505 C...qj + g -> ~qj_L + ~g
11506 IF(MINT(15).EQ.21) JS=2
11509 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11510 MINT(23-JS)=KSUSY1+21
11512 IF(JS.EQ.2) KCC=KCC+2
11515 ELSEIF(ISUB.EQ.259) THEN
11516 C...qj + g -> ~qj_R + ~g
11517 IF(MINT(15).EQ.21) JS=2
11520 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11521 MINT(23-JS)=KSUSY1+21
11523 IF(JS.EQ.2) KCC=KCC+2
11527 ELSEIF(ISUB.LE.270) THEN
11528 IF(ISUB.EQ.261) THEN
11529 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11531 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11532 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11534 C...Correct color combination
11535 IF(MINT(43).EQ.4) KCC=4
11537 ELSEIF(ISUB.EQ.262) THEN
11538 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11540 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11541 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11543 C...Correct color combination
11544 IF(MINT(43).EQ.4) KCC=4
11546 ELSEIF(ISUB.EQ.263) THEN
11547 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11548 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11549 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11550 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11551 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11554 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11555 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11557 C...Correct color combination
11558 IF(MINT(43).EQ.4) KCC=4
11560 ELSEIF(ISUB.EQ.264) THEN
11561 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11562 KCS=(-1)**INT(1.5D0+PYR(0))
11563 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11567 ELSEIF(ISUB.EQ.265) THEN
11568 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11569 KCS=(-1)**INT(1.5D0+PYR(0))
11570 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11575 ELSEIF(ISUB.LE.296) THEN
11576 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11577 C...qi + qj -> ~qi_L + ~qj_L
11579 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11580 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11581 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11583 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11584 C...qi + qj -> ~qi_R + ~qj_R
11586 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11587 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11588 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11590 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11591 C...qi + qj -> ~qi_L + ~qj_R
11592 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11593 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11595 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11597 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11598 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11599 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11600 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11602 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11604 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11605 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11606 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11607 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11609 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11611 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
11612 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11613 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11614 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11616 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11618 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
11619 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
11621 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11622 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11624 IF(MINT(43).EQ.4) KCC=4
11626 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
11627 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
11629 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11630 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11632 IF(MINT(43).EQ.4) KCC=4
11634 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
11635 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
11637 KCS=(-1)**INT(1.5D0+PYR(0))
11638 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11642 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
11643 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
11644 KCS=(-1)**INT(1.5D0+PYR(0))
11645 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11649 ELSEIF(ISUB.EQ.294) THEN
11650 C...qj + g -> ~qj_L + ~g
11651 IF(MINT(15).EQ.21) JS=2
11654 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11655 MINT(23-JS)=KSUSY1+21
11657 IF(JS.EQ.2) KCC=KCC+2
11660 ELSEIF(ISUB.EQ.295) THEN
11661 C...qj + g -> ~qj_R + ~g
11662 IF(MINT(15).EQ.21) JS=2
11665 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11666 MINT(23-JS)=KSUSY1+21
11668 IF(JS.EQ.2) KCC=KCC+2
11672 ELSEIF(ISUB.LE.340) THEN
11674 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
11675 C...q + qbar' -> H+ + H0
11676 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11677 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11678 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11679 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
11680 MINT(23-JS)=KFPR(ISUB,2)
11681 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
11682 C...f + fbar -> A0 + H0; th arbitrary
11683 IF(PYR(0).GT.0.5D0) JS=2
11684 MINT(20+JS)=KFPR(ISUB,1)
11685 MINT(23-JS)=KFPR(ISUB,2)
11686 ELSEIF(ISUB.EQ.301) THEN
11687 C...f + fbar -> H+ H-
11688 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11693 ELSEIF(ISUB.LE.360) THEN
11695 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
11696 C...l + l -> H_L++/--, H_R++/--
11697 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11698 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11699 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11701 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
11702 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
11703 IF(MINT(15).EQ.22) JS=2
11704 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
11705 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
11708 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
11709 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
11710 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
11713 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
11714 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
11715 C...as inner process).
11720 RVCKM=VINT(180+I)*PYR(0)
11723 IPM=(5-ISIGN(1,I))/2
11725 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
11726 MINT(20+JT)=ISIGN(IB,I)
11727 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11728 IF(RVCKM.LE.0D0) GOTO 450
11731 IB=2*((IA+1)/2)-1+MOD(IA,2)
11732 MINT(20+JT)=ISIGN(IB,I)
11736 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
11737 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
11739 ELSEIF(ISUB.EQ.353) THEN
11740 C...f + fbar -> Z_R0
11743 ELSEIF(ISUB.EQ.354) THEN
11744 C...f + fbar' -> W+/-
11745 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11746 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11747 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11751 ELSEIF(ISUB.LE.380) THEN
11753 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
11754 C...f + fbar -> charged+ charged- technicolor
11755 KSW=(-1)**INT(1.5D0+PYR(0))
11756 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
11757 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
11759 ELSEIF(ISUB.LE.367) THEN
11760 C...f + fbar -> neutral neutral technicolor
11761 MINT(21)=KFPR(ISUB,1)
11762 MINT(22)=KFPR(ISUB,2)
11764 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
11765 C...f + fbar' -> neutral charged technicolor
11768 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11769 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11770 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11771 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
11772 MINT(20+JS)=KFPR(ISUB,IN)
11774 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
11775 C...f + fbar' -> charged neutral technicolor
11778 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11779 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11780 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11781 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
11782 MINT(23-JS)=KFPR(ISUB,IN)
11785 ELSEIF(ISUB.LE.400) THEN
11786 IF(ISUB.EQ.381) THEN
11787 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
11789 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11791 ELSEIF(ISUB.EQ.382) THEN
11792 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
11793 MINT(21)=ISIGN(KFLF,MINT(15))
11797 ELSEIF(ISUB.EQ.383) THEN
11798 C...f + fbar -> g + g; th arbitrary, TC extensions
11803 ELSEIF(ISUB.EQ.384) THEN
11804 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
11805 IF(MINT(15).EQ.21) JS=2
11807 IF(MINT(15).EQ.21) KCC=KCC+2
11808 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11809 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11811 ELSEIF(ISUB.EQ.385) THEN
11812 C...g + g -> f + fbar; th arbitrary, TC extensions
11813 KCS=(-1)**INT(1.5D0+PYR(0))
11814 MINT(21)=ISIGN(KFLF,KCS)
11818 ELSEIF(ISUB.EQ.386) THEN
11819 C...g + g -> g + g; th arbitrary, TC extensions
11821 KCS=(-1)**INT(1.5D0+PYR(0))
11823 ELSEIF(ISUB.EQ.387) THEN
11824 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
11825 MINT(21)=ISIGN(MINT(55),MINT(15))
11829 ELSEIF(ISUB.EQ.388) THEN
11830 C...g + g -> Q + Qbar; th arbitrary, TC extensions
11831 KCS=(-1)**INT(1.5D0+PYR(0))
11832 MINT(21)=ISIGN(MINT(55),KCS)
11836 ELSEIF(ISUB.EQ.391) THEN
11837 C...f + fbar -> G*.
11840 ELSEIF(ISUB.EQ.392) THEN
11845 ELSEIF(ISUB.EQ.393) THEN
11846 C...q + qbar -> g + G*; th arbitrary.
11847 IF(PYR(0).GT.0.5D0) JS=2
11848 MINT(20+JS)=KFPR(ISUB,1)
11849 MINT(23-JS)=KFPR(ISUB,2)
11852 ELSEIF(ISUB.EQ.394) THEN
11853 C...q + g -> q + G*; th = (p(f) - p(f))**2
11854 IF(MINT(15).EQ.21) JS=2
11855 MINT(23-JS)=KFPR(ISUB,2)
11857 KCS=ISIGN(1,MINT(14+JS))
11859 ELSEIF(ISUB.EQ.395) THEN
11860 C...g + g -> G* + g; th arbitrary.
11861 IF(PYR(0).GT.0.5D0) JS=2
11862 MINT(23-JS)=KFPR(ISUB,2)
11866 ELSEIF(ISUB.LE.420) THEN
11867 IF(ISUB.EQ.401) THEN
11868 C...g + g -> t + b + H+/-
11869 KCS=(-1)**INT(1.5D0+PYR(0))
11870 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11871 MINT(22)=ISIGN(5,-KCS)
11872 KCC=11+INT(0.5D0+PYR(0))
11873 KFRES=ISIGN(KFHIGG,-KCS)
11875 ELSEIF(ISUB.EQ.402) THEN
11876 C...q + qbar -> t + b + H+/-
11877 KFL=(-1)**INT(1.5D0+PYR(0))
11878 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
11879 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
11881 KFRES=ISIGN(KFHIGG,-KFL*KCS)
11885 C...Additional code by Stefan Wolf
11886 ELSEIF(ISUB.LE.430) THEN
11887 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
11888 C...g + g -> QQ~[n] + g
11889 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
11890 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11891 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
11892 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11893 C...or from ISUB.EQ.68 (for ISUB.NE.421)
11894 C...[g + g -> g + g; th arbitrary]
11895 MINT(21)=KFPR(ISUBSV,1)
11896 MINT(22)=KFPR(ISUBSV,2)
11897 IF(ISUB.EQ.421) THEN
11899 KCS=(-1)**INT(1.5D0+PYR(0))
11902 KCS=(-1)**INT(1.5D0+PYR(0))
11905 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
11906 C...q + g -> q + QQ~[n]
11907 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
11908 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11909 C...KCC copied from ISUB.EQ.28
11910 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
11911 IF(MINT(15).EQ.21) JS=2
11912 MINT(23-JS)=KFPR(ISUBSV,2)
11914 IF(MINT(15).EQ.21) KCC=KCC+2
11915 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11916 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11918 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
11919 C...q + q~ -> g + QQ~[n]
11920 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
11921 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11922 C...KCC copied from ISUB.EQ.13
11923 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
11924 IF(PYR(0).GT.0.5) JS=2
11926 MINT(23-JS)=KFPR(ISUBSV,2)
11930 ELSEIF(ISUB.LE.440) THEN
11931 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
11932 C...g + g -> QQ~[n] + g
11933 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
11934 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11935 C...KCC and KCS copied from ISUB.EQ.86-89
11936 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11937 MINT(21)=KFPR(ISUBSV,1)
11938 MINT(22)=KFPR(ISUBSV,2)
11940 KCS=(-1)**INT(1.5D0+PYR(0))
11942 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
11943 C...q + g -> q + QQ~[n]
11944 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
11945 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11946 C...KCC and KCS copied from ISUB.EQ.112
11947 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11948 IF(MINT(15).EQ.21) JS=2
11949 MINT(23-JS)=KFPR(ISUBSV,2)
11951 KCS=ISIGN(1,MINT(14+JS))
11953 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
11954 C...q + q~ -> g + QQ~[n]
11955 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
11956 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11957 C...KCC copied from ISUB.EQ.111
11958 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11959 IF(PYR(0).GT.0.5) JS=2
11961 MINT(23-JS)=KFPR(ISUBSV,2)
11968 IF(ISET(ISUB).EQ.11) THEN
11969 C...Store documentation for user-defined processes
11970 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
11971 KUPPO(1)=MINT(83)+5
11972 KUPPO(2)=MINT(83)+6
11976 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
11985 IF(IDUP(IUP).EQ.0) K(I,2)=90
11987 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
11995 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
11998 C...Store final state partons for user-defined processes
12003 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12005 IF(IDUP(IUP).EQ.0) K(N,2)=90
12006 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12009 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12013 C...Search for daughters of intermediate colourless particles.
12014 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12015 DO 475 IUPDAU=IUP+1,NUP
12016 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12018 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12026 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12028 C...Arrange colour flow for user-defined processes
12032 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12033 IF(K(I1,1).EQ.1) K(I1,1)=3
12034 IF(K(I1,1).EQ.11) K(I1,1)=14
12035 C...Find a not yet considered colour/anticolour line.
12037 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12040 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12044 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12045 C...Find all others belonging to same line.
12048 DO 520 IUP2=IUP1+1,NUP
12051 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12052 IF(ISDE2.EQ.ISDE1) THEN
12053 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12054 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12056 ELSEIF(I4.NE.0) THEN
12057 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12058 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12060 ELSEIF(IUP2.LE.2) THEN
12061 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12062 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12065 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12066 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12076 ELSEIF(IDOC.EQ.7) THEN
12077 C...Resonance not decaying; store kinematics
12092 C...Special cases: colour flow in coloured resonances
12093 KCRES=PYCOMP(KFRES)
12094 IF(KCHG(KCRES,2).NE.0) THEN
12098 IF(KCS.EQ.-1) JC=3-J
12099 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12100 & MINT(84)+ICOL(KCC,1,JC)
12101 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12102 & MINT(84)+ICOL(KCC,2,JC)
12103 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12104 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12113 ELSEIF(IDOC.EQ.8) THEN
12114 C...2 -> 2 processes: store outgoing partons in their CM-frame
12117 KCA=PYCOMP(MINT(20+JT))
12119 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12121 K(I,3)=MINT(83)+IDOC+JT-2
12123 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12124 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12126 P(I,5)=PYMASS(K(I,2))
12128 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12129 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12131 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12132 KFA1=IABS(MINT(21))
12133 KFA2=IABS(MINT(22))
12134 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12142 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12143 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12144 P(IPU4,4)=SHR-P(IPU3,4)
12145 P(IPU4,3)=-P(IPU3,3)
12150 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12151 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12153 ELSEIF(IDOC.EQ.9) THEN
12154 C...2 -> 3 processes: store outgoing partons in their CM frame
12157 KCA=PYCOMP(MINT(20+JT))
12159 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12161 K(I,3)=MINT(83)+IDOC+JT-3
12163 C...t and b in opposide order in event list as compared to
12164 C...matrix element?
12165 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12166 IF(IABS(K(I,2)).LE.22) THEN
12167 P(I,5)=PYMASS(K(I,2))
12169 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12171 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12172 P(I,1)=PT*COS(VINT(198+5*JTA))
12173 P(I,2)=PT*SIN(VINT(198+5*JTA))
12177 K(IPU5,3)=MINT(83)+IDOC
12179 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12180 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12181 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12182 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12183 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12185 P(IPU5,3)=PMT3*SINH(VINT(211))
12186 P(IPU5,4)=PMT3*COSH(VINT(211))
12187 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12188 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12189 IF(SQL12.LE.0D0) THEN
12193 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12194 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12195 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12196 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12197 C...t and b in opposide order in event list as compared to
12199 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12200 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12201 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12203 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12204 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12210 ELSEIF(IDOC.EQ.11) THEN
12211 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12212 PHI(1)=PARU(2)*PYR(0)
12217 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12219 K(I,3)=MINT(83)+IDOC+JT-2
12220 P(I,5)=PYMASS(K(I,2))
12221 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12225 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12226 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12227 P(I,1)=PTABS*COS(PHI(JT))
12228 P(I,2)=PTABS*SIN(PHI(JT))
12229 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12230 P(I,4)=0.5D0*SHPR*Z(JT)
12234 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12238 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12239 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12240 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12247 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12248 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12249 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12250 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12259 ELSEIF(IDOC.EQ.12) THEN
12260 C...Z0 and W+/- scattering: store bosons and outgoing partons
12261 PHI(1)=PARU(2)*PYR(0)
12263 JTRAN=INT(1.5D0+PYR(0))
12267 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12269 K(I,3)=MINT(83)+IDOC+JT-2
12270 P(I,5)=PYMASS(K(I,2))
12271 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12272 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12273 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12274 P(I,1)=PTABS*COS(PHI(JT))
12275 P(I,2)=PTABS*SIN(PHI(JT))
12276 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12277 P(I,4)=0.5D0*SHPR*Z(JT)
12280 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12283 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12288 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12289 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12290 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12293 K(IPU,2)=KFPR(ISUB,JT)
12294 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12295 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12296 K(IPU,3)=MINT(83)+8+JT
12297 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12298 P(IPU,5)=PYMASS(K(IPU,2))
12300 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12302 MINT(22+JT)=K(IPU,2)
12304 C...Find rotation and boost for hard scattering subsystem
12307 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12308 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12309 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12310 GAMCM=(P(I1,4)+P(I2,4))/SHR
12311 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12312 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12313 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12314 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12315 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12316 PHICM=PYANGL(PX,PY)
12317 C...Store hard scattering subsystem. Rotate and boost it
12318 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12320 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12322 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12323 PHIWZ=VINT(24)-PHICM
12324 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12325 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12326 P(IPU5,3)=PABS*CTHWZ
12327 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12328 P(IPU6,1)=-P(IPU5,1)
12329 P(IPU6,2)=-P(IPU5,2)
12330 P(IPU6,3)=-P(IPU5,3)
12331 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12332 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12344 MINT(8)=MINT(83)+10
12347 IF(ISET(ISUB).EQ.11) THEN
12348 ELSEIF(IDOC.GE.8) THEN
12349 C...Store colour connection indices
12352 IF(KCS.EQ.-1) JC=3-J
12353 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12354 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12355 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12356 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12357 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12358 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12359 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12360 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12363 C...Copy outgoing partons to documentation lines
12365 IF(IDOC.EQ.9) IMAX=3
12367 I1=MINT(83)+IDOC-IMAX+I
12371 IF(IDOC.LE.9) K(I1,3)=0
12372 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12378 ELSEIF(IDOC.EQ.9) THEN
12379 C...Store colour connection indices
12382 IF(KCS.EQ.-1) JC=3-J
12383 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12384 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12385 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12386 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12387 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12388 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12389 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12390 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12391 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12392 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12395 C...Copy outgoing partons to documentation lines
12397 I1=MINT(83)+IDOC-3+I
12408 C...Copy outgoing partons to list of allowed radiators.
12410 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12411 DO 690 I=MINT(84)+3,N
12414 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12418 C...Low-pT events: remove gluons used for string drawing purposes
12419 IF(ISUB.EQ.95) THEN
12420 IF(MINT(35).LE.1) THEN
12421 K(IPU3,1)=K(IPU3,1)+10
12422 K(IPU4,1)=K(IPU4,1)+10
12428 DO 720 I=MINT(83)+5,MINT(83)+8
12438 C***********************************************************************
12441 C...Handles intertwined pT-ordered spacelike initial-state parton
12442 C...and multiple interactions.
12444 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12445 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12446 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12447 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12449 C...Double precision and integer declarations.
12450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12451 IMPLICIT INTEGER(I-N)
12452 INTEGER PYK,PYCHGE,PYCOMP
12455 DOUBLE PRECISION PYALPS
12456 C...Parameter statement for maximum size of showers.
12457 PARAMETER (MAXNUR=1000)
12459 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12460 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12461 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12462 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12463 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12464 COMMON/PYINT1/MINT(400),VINT(400)
12465 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12466 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12467 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12468 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12469 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12470 COMMON/PYCTAG/NCT,MCT(4000,2)
12471 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12472 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12473 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12474 C...Local arrays and saved variables.
12475 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12476 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12479 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12480 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12482 C----------------------------------------------------------------------
12483 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12484 C...done only once per event, while MODE=0 is repeated each time the
12485 C...evolution needs to be restarted.
12486 IF (MODE.EQ.-1) THEN
12490 C...Store hard scattering variables
12507 C...Set shat for hardest scattering
12509 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12512 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12516 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12517 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12518 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12520 C----------------------------------------------------------------------
12521 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12522 C...interaction initiators, with no previous evolution. Check the input
12523 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12524 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12525 C...smaller than the CM energy / 2.)
12526 ELSEIF (MODE.EQ.0) THEN
12527 C...Reset counters and switches
12533 C...Reset hard scattering variables
12544 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12545 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12548 C...Reset statistics on activity in event.
12553 C...Reset extra companion reweighting factor
12556 C...We do not generate MI for soft process (ISUB=95), but the
12557 C...initialization must be done regardless, for later purposes.
12560 C...Initialize multiple interactions.
12561 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12562 IF(MINT(51).NE.0) RETURN
12564 C...Decide whether quarks in hard scattering were valence or sea
12568 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12569 IF(MINT(51).NE.0) RETURN
12572 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12574 IF(MSTP(70).EQ.0) THEN
12576 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12577 ELSEIF(MSTP(70).EQ.1) THEN
12578 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12579 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12581 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12582 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12584 C...Also store PT2MIN in VINT(17).
12585 180 VINT(17)=PT2MIN
12587 C...Set FS masses zero now.
12591 C...Initialize IS showers with VINT(56) as max scale.
12593 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12594 IF(MINT(51).NE.0) RETURN
12598 C----------------------------------------------------------------------
12599 C...MODE= 1: Evolve event from PTMAX to PTMIN.
12600 ELSEIF (MODE.EQ.1) THEN
12602 C...Skip if no phase space.
12603 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12605 C...Starting pT2 max scale (to be udpated successively).
12608 C...Evolve two sides of the event to find which branches at highest pT.
12613 C...Loop over current shower initiators.
12614 IF (MSTP(61).GE.1) THEN
12615 DO 230 MI=1,MINT(31)
12616 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
12618 IF (MI.EQ.1) ISUB=ISUBHD
12621 C...Set up shat, initiator x values, and x remaining in BR.
12623 VINT(141)=XMI(1,MI)
12624 VINT(142)=XMI(2,MI)
12627 DO 210 JI=1,MINT(31)
12628 IF (JI.EQ.MINT(36)) GOTO 210
12629 VINT(143)=VINT(143)-XMI(1,JI)
12630 VINT(144)=VINT(144)-XMI(2,JI)
12632 C...Loop over sides.
12633 C...Generate trial branchings for this interaction. The hardest
12634 C...branching so far is automatically updated if necessary in /PYISMX/.
12637 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
12638 IF (MINT(51).NE.0) RETURN
12643 C...Generate trial additional interaction.
12644 MINT(36)=MINT(31)+1
12645 240 IF (MOD(MSTP(81),10).GE.1) THEN
12647 C...Set up X remaining in BR.
12650 DO 250 JI=1,MINT(31)
12651 VINT(143)=VINT(143)-XMI(1,JI)
12652 VINT(144)=VINT(144)-XMI(2,JI)
12654 C...Generate trial interaction
12655 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
12656 IF (MINT(51).EQ.1) RETURN
12659 C...And the winner is:
12660 IF (PT2MX.LT.PT2MIN) THEN
12662 ELSEIF (JSMX.EQ.0) THEN
12663 C...Accept additional interaction (may still fail).
12664 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
12665 IF(MINT(51).NE.0) RETURN
12666 IF (IFAIL.EQ.0) THEN
12667 SHAT(MINT(36))=VINT(44)
12668 C...Decide on flavours (valence/sea/companion).
12671 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
12672 IF(MINT(51).NE.0) RETURN
12675 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
12676 C...Reconstruct kinematics of acceptable ISR branching.
12677 C...Set up shat, initiator x values, and x remaining in BR.
12680 VINT(44)=SHAT(MINT(36))
12681 VINT(141)=XMI(1,MINT(36))
12682 VINT(142)=XMI(2,MINT(36))
12685 DO 280 JI=1,MINT(31)
12686 IF (JI.EQ.MINT(36)) GOTO 280
12687 VINT(143)=VINT(143)-XMI(1,JI)
12688 VINT(144)=VINT(144)-XMI(2,JI)
12691 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
12692 IF (MINT(51).EQ.1) RETURN
12693 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
12694 C...Bookeep joining. Cannot (yet) be constructed kinematically.
12695 MINT(354)=MINT(354)+1
12696 VINT(354)=VINT(354)+SQRT(PT2MX)
12697 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
12698 MJOIND(JSMX-2,MJN1MX)=MJN2MX
12699 MJOIND(JSMX-2,MJN2MX)=MJN1MX
12702 C...Update PT2 iteration scale.
12705 C...Loop back to continue evolution.
12706 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
12707 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
12709 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
12712 C----------------------------------------------------------------------
12713 C...MODE= 2: (Re-)store user information on hardest interaction etc.
12714 ELSEIF (MODE.EQ.2) THEN
12716 C...Revert to "ordinary" meanings of some parameters.
12718 MINT(12+JS)=K(IMI(JS,1,1),2)
12719 VINT(140+JS)=XMI(JS,1)
12720 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
12722 DO 300 MI=1,MINT(31)
12723 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
12727 C...Restore saved quantities for hardest interaction.
12742 C*********************************************************************
12745 C...Generates spacelike parton showers.
12747 SUBROUTINE PYSSPA(IPU1,IPU2)
12749 C...Double precision and integer declarations.
12750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12751 IMPLICIT INTEGER(I-N)
12752 INTEGER PYK,PYCHGE,PYCOMP
12754 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12757 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12758 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12759 COMMON/PYINT1/MINT(400),VINT(400)
12760 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12761 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12762 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
12764 C...Local arrays and data.
12765 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
12766 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
12767 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
12768 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
12769 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
12772 C...Read out basic information; set global Q^2 scale.
12777 VINT2R=VINT(2)*VINT(143)*VINT(144)
12778 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
12779 &MIN(VINT2R,PARP(67)*VINT(56))
12782 C...Define which processes ME corrections have been implemented for.
12784 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
12785 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
12786 & ISUB.EQ.144) MECOR=1
12787 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
12790 C...Initialize QCD evolution and check phase space.
12794 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
12797 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
12798 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
12799 Q2INT=SQRT(Q0S*Q2EFF)
12800 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
12801 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
12802 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
12804 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
12807 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
12808 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
12809 Q2INT=SQRT(Q0S*Q2EFF)
12810 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
12811 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
12812 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
12819 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
12821 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
12822 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
12823 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
12824 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
12828 C...Initialize QED evolution and check phase space.
12832 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
12833 &SPME=PMAS(13,1)**2
12834 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
12835 &SPME=PMAS(15,1)**2
12836 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
12839 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
12841 TEMX=LOG(Q2MX/SPME)
12842 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
12844 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
12849 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
12851 C...Loopback point in case of failure to reconstruct kinematics.
12859 IF(LOOP.GT.100) THEN
12869 C...Initial values: flavours, momenta, virtualities.
12872 KFBEAM(JT)=MINT(10+JT)
12873 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
12874 KFLS(JT)=MINT(14+JT)
12875 KFLS(JT+2)=KFLS(JT)
12877 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
12878 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
12880 Q2S(JT)=FCQ2MX*Q2MX
12887 C...Calculate initial parton distribution weights.
12888 MINT(105)=MINT(102+JT)
12889 MINT(109)=MINT(106+JT)
12890 VINT(120)=VINT(2+JT)
12891 IF(XS(JT).LT.1D0-XEE) THEN
12892 IF(MINT(31).GE.2) MINT(30)=JT
12893 IF(MSTP(57).LE.1) THEN
12894 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
12896 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
12900 XFS(JT,KFL)=XFB(KFL)
12902 C...Special kinematics check for c/b quarks (that g -> c cbar or
12903 C...b bbar kinematically possible).
12904 KFLCB=IABS(KFLS(JT))
12905 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
12906 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
12913 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
12915 C...Find if interference with final state partons.
12917 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
12921 KCA=PYCOMP(IABS(KFLS(I)))
12922 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
12924 IF(KCFI(I).NE.0) THEN
12925 IF(I.EQ.1) IPFS=IPUS1
12926 IF(I.EQ.2) IPFS=IPUS2
12928 ICSI=MOD(K(IPFS,3+J),MSTU(5))
12929 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
12930 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
12932 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
12934 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
12939 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
12942 C...Pick up leg with highest virtuality.
12946 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
12947 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
12948 IF(MORE(JT).EQ.0) JT=3-JT
12953 XFB(KFL)=XFS(JT,KFL)
12958 C...Check if allowed to branch.
12960 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
12962 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
12963 IF(XB.GE.1D0-2D0*XEC) MCEV=0
12966 IF(MINT(44+JT).EQ.3) THEN
12968 IF(XB.GE.1D0-2D0*XEE) MEEV=0
12969 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
12971 C***Currently kill QED shower for resolved photoproduction.
12972 IF(MINT(18+JT).EQ.1) MEEV=0
12973 C***Currently kill shower for W inside electron.
12974 IF(IABS(KFLB).EQ.24) THEN
12979 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
12981 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
12986 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
12990 IF(MSTP(62).LE.1) THEN
12991 IF(ZS(JT).GT.0.99999D0) THEN
12994 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
12995 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
12996 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
12998 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
12999 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13002 ALSDUM=PYALPS(FQ2C*Q2B)
13003 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13005 B0=(33D0-2D0*MSTU(118))/6D0
13007 IF(MEEV.EQ.2) TEVEB=TEVCB
13011 C...Select side for interference with final state partons.
13012 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13015 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13017 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13018 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13019 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13021 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13025 C...Calculate preweighting factor for ME-corrected processes.
13026 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13028 C...Calculate Altarelli-Parisi weights.
13034 C...q -> q (g or gamma emission), g -> q.
13035 IF(IABS(KFLB).LE.10) THEN
13036 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13037 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13039 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13040 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13042 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13043 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13044 WTAPC(21)=WTGF*WTAPC(21)
13045 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13047 C...f -> f, gamma -> f.
13048 ELSEIF(IABS(KFLB).LE.20) THEN
13049 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13050 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13051 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13052 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13053 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13054 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13055 WTAPE(22)=WTGF*WTAPE(22)
13057 C...f -> g, g -> g.
13058 ELSEIF(KFLB.EQ.21) THEN
13059 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13060 DO 180 KFL=1,MSTP(58)
13064 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13065 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13066 DO 190 KFL=1,MSTP(58)
13067 WTAPC(KFL)=WTFG*WTAPC(KFL)
13068 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13070 WTAPC(21)=WTGG*WTAPC(21)
13072 C...f -> gamma, W+, W-.
13073 ELSEIF(KFLB.EQ.22) THEN
13074 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13077 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13078 WTAPE(11)=WTFG*WTAPE(11)
13079 WTAPE(-11)=WTFG*WTAPE(-11)
13081 ELSEIF(KFLB.EQ.24) THEN
13082 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13083 & (XEE*(XB+XEE)))/XB
13084 ELSEIF(KFLB.EQ.-24) THEN
13085 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13086 & (XEE*(XB+XEE)))/XB
13089 C...Calculate parton distribution weights and sum.
13092 IF(NTRY.GT.500) THEN
13098 XFBO=MAX(1D-10,XFB(KFLB))
13100 WTSF(KFL)=XFB(KFL)/XFBO
13101 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13102 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13104 WTSUMC=MAX(0.0001D0,WTSUMC)
13105 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13107 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13110 IF(NTRY2.GT.500) THEN
13115 IF(MSTP(64).LE.0) THEN
13116 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13117 ELSEIF(MSTP(64).EQ.1) THEN
13118 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13120 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13124 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13125 & (PARU(101)*FWTE*WTSUME*TEMX)))
13126 ELSEIF(MEEV.EQ.2) THEN
13127 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13130 C...Translate t into Q2 scale; choose between QCD and QED evolution.
13131 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13132 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13133 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13134 C...Ensure that Q2 is above threshold for charm/bottom.
13136 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13138 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13139 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13140 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13141 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13144 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13146 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13149 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13150 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13151 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13152 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13153 IF(Q2EB.GT.Q2MNE) MCE=2
13154 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13155 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13156 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13157 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13158 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13159 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13161 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13162 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13165 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13166 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13169 C...Evolution possibly ended. Update t values.
13173 ELSEIF(MCE.EQ.1) THEN
13176 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13177 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13181 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13184 C...Select flavour for branching parton.
13185 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13186 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13189 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13190 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13191 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13192 IF(KFLA.EQ.25) THEN
13197 C...Choose z value and corrective weight.
13199 C...q -> q + g or q -> q + gamma.
13200 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13201 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13202 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13203 WTZ=0.5D0*(1D0+Z**2)
13205 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13206 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13207 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13208 C...f -> f + gamma.
13209 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13210 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13211 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13212 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13214 Z=XB+XB*(XEE/(1D0-XEE))*
13215 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13217 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13218 C...f -> gamma + f.
13219 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13220 Z=XB+XB*(XEE/(1D0-XEE))*
13221 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13222 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13224 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13225 Z=XB+XB*(XEE/(1D0-XEE))*
13226 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13227 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13228 & (Q2B/(Q2B+PMAS(24,1)**2))
13230 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13231 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13232 WTZ=1D0-2D0*Z*(1D0-Z)
13234 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13235 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13236 WTZ=(1D0-Z*(1D0-Z))**2
13237 C...gamma -> f + fbar.
13238 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13239 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13240 WTZ=1D0-2D0*Z*(1D0-Z)
13242 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13244 C...Option with resummation of soft gluon emission as effective z shift.
13246 IF(MSTP(65).GE.1) THEN
13248 IF(KFLB.NE.21) RSOFT=8D0/3D0
13249 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13250 IF(Z.LE.XB) GOTO 220
13253 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13254 IF(MSTP(64).GE.2) THEN
13255 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13256 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13257 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13258 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13262 C...Remove kinematically impossible branchings.
13263 UHAT=Q2B-DSH*(1D0-Z)/Z
13264 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13266 C...Select phi angle of branching at random.
13267 PHIBR=PARU(2)*PYR(0)
13269 C...Matrix-element corrections for some processes.
13270 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13271 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13272 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13274 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13275 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13277 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13278 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13280 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13281 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13286 C...Impose angular constraint in first branching from interference
13287 C...with final state partons.
13289 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13290 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13291 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13292 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13293 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13294 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13298 C...Option with angular ordering requirement.
13299 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13300 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13301 IF(THE2T.GT.THE2(JT)) GOTO 220
13305 C...Weighting with new parton distributions.
13306 MINT(105)=MINT(102+JT)
13307 MINT(109)=MINT(106+JT)
13308 VINT(120)=VINT(2+JT)
13309 IF(MINT(31).GE.2) MINT(30)=JT
13310 IF(MSTP(57).LE.1) THEN
13311 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13313 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13316 IF(XFBN.LT.1D-20) THEN
13317 IF(KFLA.EQ.KFLB) THEN
13323 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13324 TEVCB=0.5D0*(TEVCBS+TEVCB)
13326 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13327 TEVEB=0.5D0*(TEVEBS+TEVEB)
13338 IF(MINT(31).GE.2) MINT(30)=JT
13339 IF(MSTP(57).LE.1) THEN
13340 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13342 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13345 IF(XFAN.LT.1D-20) GOTO 200
13347 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13349 C...Define two hard scatterers in their CM-frame.
13350 260 IF(N.EQ.NS+2) THEN
13352 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13355 IF(JR.EQ.1) IPO=IPUS1
13356 IF(JR.EQ.2) IPO=IPUS2
13366 P(I,3)=DPLCM*(-1)**(JR+1)
13367 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13368 P(I,5)=-SQRT(DQ2(JR))
13371 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13372 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13375 C...Find maximum allowed mass of timelike parton.
13376 ELSEIF(N.GT.NS+2) THEN
13381 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13382 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13383 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13384 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13385 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13387 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13388 & 1D-10*DPD(1)) IKIN=1
13389 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13390 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13391 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13392 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13394 C...Generate timelike parton shower (if required).
13401 C...f -> f + g (gamma).
13402 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13404 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13405 C...f -> g (gamma, W+-) + f.
13406 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13408 IF(KFLS(JT+2).EQ.24) THEN
13410 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13413 C...g (gamma) -> f + fbar, g + g.
13415 K(IT,2)=-KFLS(JT+2)
13416 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13419 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13420 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13421 P(IT,5)=PYMASS(K(IT,2))
13422 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13423 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13426 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13427 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13428 IF(MSTP(63).EQ.1) THEN
13430 ELSEIF(MSTP(63).EQ.2) THEN
13431 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13435 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13436 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13437 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13438 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13439 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13441 CALL PYSHOW(IT,0,SQRT(Q2TIM))
13444 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13447 C...Reconstruct kinematics of branching: timelike parton shower.
13449 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13450 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13451 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13452 & (4D0*DSH*DPC(3)**2)
13453 IF(DPT2.LT.0D0) GOTO 100
13454 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13455 & DSHR)/DPC(3)-DPC(3)
13457 P(IT,3)=DPB(1)*(-1)**(JT+1)
13458 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13460 DPB(1)=SQRT(DPB(1)**2+DPT2)
13461 DPB(2)=SQRT(DPB(1)**2+DMS)
13463 DPB(4)=SQRT(DPB(3)**2+DMS)
13464 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13466 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13467 THE=PYANGL(P(IT,3),P(IT,1))
13468 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13471 C...Reconstruct kinematics of branching: spacelike parton.
13480 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13481 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13482 P(N+1,5)=-SQRT(DQ2(3))
13484 C...Define colour flow of branching.
13489 C...f -> f + gamma (Z, W).
13490 IF(IABS(K(IT,2)).GE.22) THEN
13494 C...f -> gamma (Z, W) + f.
13495 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13498 C...gamma -> q + qbar, g + g.
13499 ELSEIF(K(N+1,2).EQ.22) THEN
13505 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13509 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13512 C...qbar -> qbar + g.
13513 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13516 C...qbar -> g + qbar.
13517 ELSEIF(K(N+1,2).LT.0) THEN
13520 C...g -> g + g; g -> q + qbar.
13521 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13528 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13529 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13530 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13531 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13532 IF(ID1.NE.ID2) THEN
13533 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13534 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13537 IF(K(IT,1).EQ.1) THEN
13542 C...Boost to new CM-frame.
13543 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13544 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13545 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13546 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13547 IR=N+(JT-1)*(IS(1)-N)
13548 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13551 C...Global statistics.
13552 MINT(352)=MINT(352)+1
13553 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13554 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13557 C...Update kinematics variables.
13560 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
13563 C...Save quantities; loop back.
13567 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13568 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13569 KFLS(JT+2)=KFLS(JT)
13574 XFS(JT,KFL)=XFA(KFL)
13583 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13584 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13585 IF(MSTU(21).GE.1) N=NS
13586 IF(MSTU(21).GE.1) RETURN
13588 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13590 C...Boost hard scattering partons to frame of shower initiators.
13592 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13598 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
13599 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
13600 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13602 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
13603 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
13604 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
13606 C...Store user information. Reset Lambda value.
13607 IF(MINT(31).LE.1) THEN
13608 K(IPU1,3)=MINT(83)+3
13609 K(IPU2,3)=MINT(83)+4
13611 K(IPU1,3)=MINT(83)+1
13612 K(IPU2,3)=MINT(83)+2
13615 MINT(12+JT)=KFLS(JT)
13616 VINT(140+JT)=XS(JT)
13617 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
13618 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
13625 C*********************************************************************
13628 C...Generates pT-ordered spacelike initial-state parton showers and
13629 C...trial joinings.
13630 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
13631 C... interaction initiators at PT2NOW.
13632 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
13633 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
13634 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
13635 C... is below PT2CUT.
13636 C... (Also generate test joinings if MSTP(96)=1.)
13637 C...MODE= 1: Accept stored shower branching. Update event record etc.
13638 C...PT2NOW : Starting (max) PT2 scale for evolution.
13639 C...PT2CUT : Lower limit for evolution.
13640 C...PT2 : Result of evolution. Generated PT2 for trial emission.
13641 C...IFAIL : Status return code. IFAIL=0 when all is well.
13643 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
13645 C...Double precision and integer declarations.
13646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13647 IMPLICIT INTEGER(I-N)
13648 INTEGER PYK,PYCHGE,PYCOMP
13649 C...Parameter statement for maximum size of showers.
13650 PARAMETER (MAXNUR=1000)
13652 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13655 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13656 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13657 COMMON/PYINT1/MINT(400),VINT(400)
13658 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13659 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13660 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13661 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13662 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13663 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13664 COMMON/PYCTAG/NCT,MCT(4000,2)
13665 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13666 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13667 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
13668 C...Local variables
13669 DIMENSION ZSAV(2,240),PT2SAV(2,240),
13670 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
13671 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
13672 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
13673 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
13674 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
13675 C...For check on excessive weights.
13682 C----------------------------------------------------------------------
13683 C...MODE=-1: Initialize initial state showers from scratch, i.e.
13684 C...starting from the hardest interaction initiators.
13685 IF (MODE.EQ.-1) THEN
13686 C...Set hard scattering SHAT.
13688 C...Mass thresholds and Lambda for QCD evolution.
13689 AEM2PI=PARU(101)/PARU(2)
13693 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13694 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13695 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
13696 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13699 C...Massive quark forced creation threshold (in M**2).
13701 C...Set upper limit for X (ensures some X left for beam remnant).
13702 XMXC=1D0-2D0*PARP(111)/VINT(1)
13704 IF (MSTP(61).GE.1) THEN
13705 C...Initial values: flavours, momenta, virtualities.
13709 C...Special kinematics check for c/b quarks (that g -> c cbar or
13710 C...b bbar kinematically possible).
13711 KFLB=K(IMI(JS,1,1),2)
13713 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13714 C...Check PT2MAX > mQ^2
13715 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
13716 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
13717 & 'No Q creation possible.')
13721 C...Check for physical z values (m == MQ / sqrt(s))
13722 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
13723 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
13724 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
13725 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
13726 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
13737 C...Zero joining array
13743 C----------------------------------------------------------------------
13744 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
13745 C...MINT(30). Store if emission PT2 scale is largest so far.
13746 C...Also generate test joinings if MSTP(96)=1.
13747 ELSEIF(MODE.EQ.0) THEN
13752 C...No shower for structureless beam
13753 IF (MINT(44+JS).EQ.1) RETURN
13756 C...Absolute shower max scale = VINT(56)
13757 PT2=MIN(PT2NOW,VINT(56))
13758 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
13759 C...Define for which processes ME corrections have been implemented.
13760 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13761 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
13762 & .142.OR.ISUB.EQ.144) MECOR=1
13763 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13764 C...Calculate preweighting factor for ME-corrected processes.
13765 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13767 C...Basic info on daughter for which to find mother.
13768 KFLB=K(IMI(JS,MI,1),2)
13770 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
13771 C...second companion.
13772 KSVCB=MAX(-1,IMI(JS,MI,2))
13773 C...Treat "first" companion of a pair like an ordinary sea quark
13774 C...(except that creation diagram is not allowed)
13775 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
13776 C...X (rescaled to [0,1])
13777 XB=XMI(JS,MI)/VINT(142+JS)
13778 C...Massive quarks (use physical masses.)
13781 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
13783 IF (KFLBA.EQ.5) RMQ2=RMB2
13784 C...Special threshold treatment for non-photon beams
13785 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
13788 C...Flags for parton distribution calls.
13789 MINT(105)=MINT(102+JS)
13790 MINT(109)=MINT(106+JS)
13791 VINT(120)=VINT(2+JS)
13793 C...Calculate initial parton distribution weights.
13794 IF(XB.GE.XMXC) THEN
13796 ELSEIF(MQMASS.EQ.0) THEN
13797 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
13799 C...Initialize massive quark PT2 dependent pdf underestimate.
13801 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
13802 C.!.Tentative treatment of massive valence quarks.
13803 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
13805 TPM0=LOG(PT20/RMQ2)
13808 IF (KFLB.NE.21) THEN
13809 C...For quarks, only include respective sea, val, or cmp part.
13810 IF (KSVCB.LE.0) THEN
13811 XFB(KFLB)=XPSVC(KFLB,KSVCB)
13813 C...Find companion's companion
13816 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
13820 C...Momentum fraction of the companion quark.
13821 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
13823 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
13827 C...Determine overestimated z range: switch at c and b masses.
13828 130 IF (PT2.GT.TMIN*RMB2) THEN
13830 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
13833 ELSEIF(PT2.GT.TMIN*RMC2) THEN
13835 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
13844 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
13845 ALAM2=ALAM2/PARP(64)
13846 C...Overestimated ZMAX:
13847 IF (MQMASS.EQ.0) THEN
13849 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
13852 C...Massive (limit for bremsstrahlung diagram > creation)
13853 FMQ=SQRT(RMQ2/SHTNOW(MI))
13858 C...If kinematically impossible then do not evolve.
13859 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
13861 C...Reset Altarelli-Parisi and PDF weights.
13868 C...Zero joining weights and compute X(partner) and X(mother) values.
13869 IF (MSTP(96).NE.0) THEN
13871 DO 150 MJ=1,MINT(31)
13874 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
13875 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
13880 C...Approximate Altarelli-Parisi weights (integrated AP dz).
13881 C...q -> q, g -> q or q -> q + gamma (already set which).
13882 IF(KFLBA.LE.5) THEN
13883 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
13884 IF (KSVCB.LT.0) THEN
13885 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
13887 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
13888 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
13889 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
13891 WTAP(21)=0.5D0*(ZMAX-ZMIN)
13892 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
13893 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
13894 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
13895 WTAP(KFLB)=WTFF*WTAP(KFLB)
13896 WTAP(21)=WTGF*WTAP(21)
13899 IF (KSVCB.GE.1) THEN
13900 C...Kill normal creation but add joining diagrams for cmp quark.
13902 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
13903 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
13904 & " quark here. Not handled yet, giving up!")
13909 C...Check for possible joinings
13910 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
13911 C...Find companion's companion.
13914 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
13915 IF (MJOIND(JS,MJ).EQ.0) THEN
13918 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
13919 IF (WTAPJ(MJ).GT.1D-6) THEN
13925 C...Add trial gluon joinings.
13926 DO 170 MJ=1,MINT(31)
13927 KFLC=K(IMI(JS,MJ,1),2)
13928 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
13929 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
13930 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
13931 IF (WTAPJ(MJ).GT.1D-6) THEN
13938 ELSEIF (IMI(JS,MI,2).GE.0) THEN
13939 C...Kill creation diagram for val quarks and sea quarks with companions.
13941 ELSEIF (MQMASS.EQ.0) THEN
13942 C...Extra safety factor for massless sea quark creation.
13943 WTAP(21)=WTAP(21)*1.25D0
13946 C... q -> g, g -> g.
13947 ELSEIF(KFLB.EQ.21) THEN
13948 C...Here we decide later whether a quark picked up is valence or
13949 C...sea, so we maintain the extra factor sqrt(z) since we deal
13950 C...with the *sum* of sea and valence in this context.
13951 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
13952 C...new: do not allow backwards evol to pick up heavy flavour.
13953 DO 180 KFL=1,MIN(3,MSTP(58))
13957 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
13958 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
13960 WTAP(21)=WTGG*WTAP(21)
13962 C...Check for possible joinings (companions handled separately above)
13963 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
13965 DO 190 MJ=1,MINT(31)
13966 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
13968 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
13969 IF (KSVCC.GE.1) GOTO 190
13970 KFLC=K(IMI(JS,MJ,1),2)
13971 C...Only try g -> g + g once.
13972 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
13973 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
13974 IF (KFLC.EQ.21) THEN
13975 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
13977 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
13979 IF (WTAPJ(MJ).GT.1D-6) THEN
13988 C...Initialize massive quark evolution
13989 IF (MQMASS.NE.0) THEN
13990 RML=(RMQ2+VINT(18))/ALAM2
13992 TPL=LOG((PT2+VINT(18))/ALAM2)
13993 TPM=LOG((PT2+VINT(18))/RMQ2)
13994 WN=WTAP(21)*WPDF0/B0
13998 C...Loopback point for iteration
14002 IF(NTRY.GT.500) THEN
14003 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14008 C... Calculate PDF weights and sum for evolution rate.
14010 XFBO=MAX(1D-10,XFB(KFLB))
14012 WTPDF(KFL)=XFB(KFL)/XFBO
14013 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14015 C...Only add gluon mother diagram for massless KFLB.
14016 IF(MQMASS.EQ.0) THEN
14017 WTPDF(21)=XFB(21)/XFBO
14018 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14020 WTSUM=MAX(0.0001D0,WTSUM)
14022 C...Add joining diagrams where applicable.
14024 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14025 DO 220 MJ=1,MINT(31)
14026 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14027 WTPDFJ(MJ)=1D0/XFBO
14028 C...x and x*pdf (+ sea/val) for parton C.
14029 KFLC=K(IMI(JS,MJ,1),2)
14031 KSVCC=MAX(-1,IMI(JS,MJ,2))
14032 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14035 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14037 IF (KFLC.NE.21.AND.KSVCC.LE.0) THEN
14038 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14039 ELSEIF (KSVCC.GE.1) THEN
14040 print*, 'error! parton C is companion!'
14042 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14043 C...x and x*pdf (+ sea/val) for parton A.
14046 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14049 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14054 IF (KSVCA.LE.0) THEN
14055 C...Consider C the "evolved" parton if B is gluon. Val/sea
14056 C...counting will then be done correctly in PYPDFU.
14057 IF (KFLBA.EQ.21) MINT(36)=MJ
14058 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14060 IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14062 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14063 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14065 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14066 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14070 C...Pick normal pT2 (in overestimated z range).
14073 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14076 C...Evolve q -> q gamma separately, pick it if larger pT.
14077 IF(KFLBA.LE.5) THEN
14078 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14079 IF(PT2QED.GT.PT2) THEN
14086 C... Evolve massive quark creation separately.
14088 IF (MQMASS.NE.0) THEN
14089 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14091 C... Ensure mininimum PT2CR and force creation near threshold.
14092 IF (PT2CR.LT.TMIN*RMQ2) THEN
14094 IF (NTHRES.GT.50) THEN
14095 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14096 & 'massive quark creation. Gave up trying.')
14104 C... Select largest PT2 (brems or creation):
14105 IF (PT2CR.GT.PT2) THEN
14114 C... Compute logarithms for this PT2
14115 TPL=LOG((PT2+VINT(18))/ALAM2)
14116 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14117 WTCRQQ=TPM/LOG(PT2/RMQ2)
14120 C...Evolve joining separately
14122 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14123 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14125 IF (PT2JN.GE.PT2) THEN
14131 C...Loopback if crossed c/b mass thresholds.
14132 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14135 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14140 C...Speed up shower. Skip if higher-PT acceptable branching
14141 C...already found somewhere else.
14142 C...Also finish if below lower cutoff.
14144 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14146 C...Select parton A flavour (massive Q handled above.)
14147 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14151 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14152 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14153 IF(KFLA.EQ.6) KFLA=21
14154 ELSEIF (MJOIN.EQ.1) THEN
14155 C...Tentative joining accept/reject.
14156 WTRAN=PYR(0)*WTJOIN
14159 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14160 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14161 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14162 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14166 C...x*pdf (+ sea/val) at new pT2 for parton B.
14167 IF (KSVCB.LE.0) THEN
14169 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14170 IF (KFLB.NE.21) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14172 C...Companion distributions do not evolve.
14175 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14176 KFLC=K(IMI(JS,MJ,1),2)
14178 KSVCC=MAX(-1,IMI(JS,MJ,2))
14179 IF (KSVCB.GE.1) KSVCC=-1
14180 C...x*pdf (+ sea/val) at new pT2 for parton C.
14183 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14185 IF (KFLC.NE.21.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14186 WTVETO=WTVETO/XFJ(KFLC)
14187 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14190 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14193 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14197 IF (KSVCA.LE.0) THEN
14199 IF (KFLB.EQ.21) MINT(36)=MJ
14200 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14202 IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14204 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14206 WTVETO=WTVETO*XFJ(KFLA)
14207 C...Monte Carlo veto.
14208 IF (WTVETO.LT.PYR(0)) GOTO 200
14209 C...If accept, save PT2 of this joining.
14210 IF (PT2.GT.PT2MX) THEN
14218 C...Exit and continue evolution.
14223 C...Choose z value (still in overestimated range) and corrective weight.
14224 C...Unphysical z will be rejected below when Q2 has is computed.
14227 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14228 C...q -> q + g or q -> q + gamma (already set which).
14229 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14230 IF (KSVCB.LT.0) THEN
14231 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14233 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14234 Z=((1-ZFAC)/(1+ZFAC))**2
14236 WTZ=0.5D0*(1D0+Z**2)
14237 C...Massive weight correction.
14238 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14239 C...Valence quark weight correction (extra sqrt)
14240 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14243 C...NB: MQ>0 not yet implemented. Forced absent above.
14244 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14246 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14247 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14250 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14252 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14253 WTZ=Z**2+(1D0-Z)**2
14254 C...Massive correction
14255 IF (MQMASS.NE.0) THEN
14256 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14257 C...Extra safety margin for light sea quark creation
14258 ELSEIF (KSVCB.LT.0) THEN
14263 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14265 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14266 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14267 WTZ=(1D0-Z*(1D0-Z))**2
14270 C...Derive Q2 from pT2.
14272 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14274 C...Loopback if outside allowed z range for given pT2.
14275 RM2C=PYMASS(KFLC)**2
14276 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14277 IF (PT2ADJ.LT.1D-6) GOTO 230
14279 C...Loopback if nonordered in angle/rapidity.
14280 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14281 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14285 C...Select phi angle of branching at random.
14288 C...Matrix-element corrections for some processes.
14289 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14290 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14291 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14293 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14294 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14296 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14297 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14299 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14300 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14305 C...Parton distributions at new pT2 but old x.
14307 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14308 C...Treat val and cmp separately
14309 IF (KFLB.NE.21.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14311 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14313 IF(XFBN.LT.1D-20) THEN
14314 IF(KFLA.EQ.KFLB) THEN
14327 C...Parton distributions at new pT2 and new x.
14330 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14331 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14332 C...q -> q + g: only consider respective sea, val, or cmp content.
14333 IF (KSVCB.LE.0) THEN
14334 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14337 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14341 IF(XFAN.LT.1D-20) THEN
14345 C...If weighting fails continue evolution.
14347 IF (MCRQQ.EQ.0) THEN
14348 WTPDFA=1D0/WTPDF(KFLA)
14349 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14350 ELSEIF(MCRQQ.EQ.1) THEN
14352 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14354 ELSEIF(MCRQQ.EQ.2) THEN
14355 C...Force massive quark creation.
14359 C...Loop back if trial emission fails.
14360 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14361 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14362 IF(WTTOT.LT.0D0) THEN
14363 WRITE(CHWT,'(1P,E12.4)') WTTOT
14364 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14365 ELSEIF(WTTOT.GT.WTACC) THEN
14366 WRITE(CHWT,'(1P,E12.4)') WTTOT
14367 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14368 C...Too high weight: write out as error, but do not update error counter.
14369 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14371 & '(PYPTIS:) Weight '//CHWT//' above unity')
14372 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14373 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14376 & '(PYPTIS:) Weight '//CHWT//' above unity')
14378 C...Useful for debugging but commented out for distribution:
14379 C print*, 'JS, MI',JS, MI
14380 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14381 C print*, 'A -> B C',KFLA, KFLB, KFLC
14383 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14386 C...Save acceptable branching.
14387 IF(PT2.GT.PT2MX) THEN
14400 C----------------------------------------------------------------------
14401 C...MODE= 1: Accept stored shower branching. Update event record etc.
14402 ELSEIF (MODE.EQ.1) THEN
14407 C...Shift down rest of event record to make room for insertion.
14412 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14413 KT1=K(I,4)/MSTU(5)**2
14414 KT2=K(I,5)/MSTU(5)**2
14415 ID1=MOD(K(I,4),MSTU(5))
14416 ID2=MOD(K(I,5),MSTU(5))
14417 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14418 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14419 IF (ID1.GE.IT) ID1=ID1+2
14420 IF (ID2.GE.IT) ID2=ID2+2
14421 IF (IM1.GE.IT) IM1=IM1+2
14422 IF (IM2.GE.IT) IM2=IM2+2
14423 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14424 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14430 MCT(I+2,1)=MCT(I,1)
14431 MCT(I+2,2)=MCT(I,2)
14434 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14435 DO 290 JI=1,MINT(31)
14436 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14437 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14438 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14439 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14440 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14441 C...Also update companion pointers to the present mother.
14442 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14445 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14447 C...Zero entries dedicated for new timelike and mother partons.
14458 C...Define timelike and new mother partons. History.
14465 C...Set mother origin = side.
14466 K(IM,3)=MINT(83)+JS+2
14467 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14469 C...Define colour flow of branching.
14472 C...q -> q + gamma.
14473 IF(K(IT,2).EQ.22) THEN
14478 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14482 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14485 C...qbar -> qbar + g.
14486 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14489 C...qbar -> g + qbar.
14490 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14493 C...g -> g + g; g -> q + qbar..
14494 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14501 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14502 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14503 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14504 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14505 IF(ID1.NE.ID2) THEN
14506 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14507 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14509 IF(K(IT,1).EQ.1) THEN
14513 C...Update IMI and colour tag arrays.
14521 C...If mother flag not yet set for spacelike parton, trace it.
14522 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14523 IF(MINT(51).NE.0) RETURN
14527 C...If mother flag not yet set for timelike parton, trace it.
14528 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14529 IF(MINT(51).NE.0) RETURN
14532 C...Boost recoiling parton to compensate for Q2 scale.
14533 C...(Also update recoiler in documentation lines, if necessary.)
14534 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14535 & (1D0+(1D0+Q2BMX/SHAT)**2)
14537 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14538 IF (IR.EQ.MINT(84)+3-JS) CALL PYROBO(MINT(83)+7-JS,MINT(83)
14539 & +7-JS,0D0,0D0,0D0,0D0,BETAZ)
14541 C...Rotate back system in phi to compensate for subsequent rotation.
14542 C...(not including the just added partons.)
14543 IMIN=IMISEP(MI-1)+1
14544 IF (MI.EQ.1) IMIN=MINT(83)+5
14546 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14548 C...Define kinematics of new partons in old frame.
14550 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14551 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14552 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14553 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14555 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14556 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14557 P(IT,5)=SQRT(RM2CMX)
14559 C...Boost and rotate to new frame.
14560 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14561 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14562 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14563 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14568 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14570 THETA=PYANGL(P(I1,3),P(I1,1))
14571 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14573 C...Global statistics.
14574 MINT(352)=MINT(352)+1
14575 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14576 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14578 C...Add parton with relevant pT scale for timelike shower.
14579 IF (K(IT,2).NE.22) THEN
14582 PTPART(NPART)=SQRT(PT2AMX)
14585 C...Update saved variables.
14586 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
14587 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
14588 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
14589 PT2SAV(JSMX,MIMX)=PT2MX
14594 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
14595 C...Gluon reconstructs to quark.
14596 C...Decide whether newly created quark is valence or sea:
14598 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
14599 IF(MINT(51).NE.0) RETURN
14601 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
14602 C...Quark reconstructs to gluon.
14603 C...Now some guy may have lost his companion. Check.
14605 IF (ICMP.GT.0) THEN
14606 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
14607 & //' away. Cannot handle that yet. Giving up.')
14610 ELSEIF(ICMP.LT.0) THEN
14611 C...A sea quark with companion still in BR was reconstructed to a gluon.
14612 C...Companion should now be removed from the beam remnant.
14613 C...(Momentum integral is automatically updated in next call to PYPDFU.)
14616 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
14617 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
14618 DO 360 JI=1,MINT(31)
14620 JFL=-K(IMI(JS,JI,1),2)
14621 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
14625 NVC(JS,IFL)=NVC(JS,IFL)-1
14627 C...Set gluon IMI(JS,MI,2) = 0.
14629 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
14630 C...Quark reconstructing to quark. If sea with companion still in BR
14631 C...then update associated x value.
14632 C...(Momentum integral is automatically updated in next call to PYPDFU.)
14633 IF (IMI(JS,MI,2).LT.0) THEN
14636 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
14642 C...If reached this point, normal exit.
14648 C*********************************************************************
14651 C...Generates maximum ME weight in some initial-state showers.
14652 C...Inparameter MECOR: kind of hard scattering process
14653 C...Outparameter WTFF: maximum weight for fermion -> fermion
14654 C... WTGF: maximum weight for gluon/photon -> fermion
14655 C... WTFG: maximum weight for fermion -> gluon/photon
14656 C... WTGG: maximum weight for gluon -> gluon
14658 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14660 C...Double precision and integer declarations.
14661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14662 IMPLICIT INTEGER(I-N)
14663 INTEGER PYK,PYCHGE,PYCOMP
14665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14667 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14668 COMMON/PYINT1/MINT(400),VINT(400)
14669 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14670 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
14672 C...Default maximum weight.
14678 C...Select maximum weight by process.
14679 IF(MECOR.EQ.1) THEN
14682 ELSEIF(MECOR.EQ.2) THEN
14690 C*********************************************************************
14693 C...Calculates actual ME weight in some initial-state showers.
14694 C...Inparameter MECOR: kind of hard scattering process
14695 C... IFLCB: flavour combination of branching,
14696 C... 1 for fermion -> fermion,
14697 C... 2 for gluon/photon -> fermion
14698 C... 3 for fermion -> gluon/photon,
14699 C... 4 for gluon -> gluon
14700 C... Q2: Q2 value of shower branching
14701 C... Z: Z value of branching
14702 C...In+outparameter PHIBR: azimuthal angle of branching
14703 C...Outparameter WTME: actual ME weight
14705 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
14707 C...Double precision and integer declarations.
14708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14709 IMPLICIT INTEGER(I-N)
14710 INTEGER PYK,PYCHGE,PYCOMP
14712 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14714 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14715 COMMON/PYINT1/MINT(400),VINT(400)
14716 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14717 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
14719 C...Default output.
14722 C...Define kinematics of shower branching in Mandelstam variables.
14726 UH=Q2-SQM*(1D0-Z)/Z
14728 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
14729 IF(MECOR.EQ.1) THEN
14730 IF(IFLCB.EQ.1) THEN
14731 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
14732 ELSEIF(IFLCB.EQ.2) THEN
14733 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
14736 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
14737 ELSEIF(MECOR.EQ.2) THEN
14738 IF(IFLCB.EQ.3) THEN
14739 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
14740 ELSEIF(IFLCB.EQ.4) THEN
14741 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
14748 C*********************************************************************
14751 C...Handles the generation of additional interactions in the new
14752 C...multiple interactions framework.
14753 C...MODE=-1 : Initalize MI from scratch.
14754 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
14755 C... Sudakov for PT2, abort if below PT2CUT.
14756 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
14757 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
14758 C...PT2NOW : Starting (max) PT2 scale for evolution.
14759 C...PT2CUT : Lower limit for evolution.
14760 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
14761 C...IFAIL : Status return code.
14762 C... = 0: All is well.
14763 C... < 0: Phase space exhausted, generation to be terminated.
14764 C... > 0: Additional interaction vetoed, but continue evolution.
14766 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14767 C...Double precision and integer declarations.
14768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14769 IMPLICIT INTEGER(I-N)
14770 INTEGER PYK,PYCHGE,PYCOMP
14771 C...Parameter statement for maximum size of showers.
14772 PARAMETER (MAXNUR=1000)
14774 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14775 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14777 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14778 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14780 COMMON/PYINT1/MINT(400),VINT(400)
14781 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14782 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14783 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14784 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14785 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14786 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14787 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14788 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14789 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14790 COMMON/PYCTAG/NCT,MCT(4000,2)
14791 C...Local arrays and saved variables.
14792 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
14794 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
14795 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
14796 & /PYISMX/,/PYCTAG/
14800 C...Set MI subprocess = QCD 2 -> 2.
14803 C----------------------------------------------------------------------
14804 C...MODE=-1: Initialize from scratch
14805 IF (MODE.EQ.-1) THEN
14806 C...Initialize PT2 array.
14808 C...Initialize list of incoming beams and partons from two sides.
14815 IMI(JS,1,1)=MINT(84)+JS
14817 XMI(JS,1)=VINT(40+JS)
14818 C...Rescale x values to fractions of photon energy.
14819 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
14820 C...Hard reset: hard interaction initiators motherless by definition.
14821 K(MINT(84)+JS,3)=2+JS
14822 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
14823 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
14827 IF (MOD(MSTP(81),10).GE.1) THEN
14828 IF(MSTP(82).LE.1) THEN
14829 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
14831 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14832 & VINT(317)/(VINT(318)*VINT(320))
14833 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14835 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14836 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14839 C...Zero entries relating to scatterings beyond the first.
14845 IMISEP(MI)=IMISEP(1)
14850 C...Initialize factors for PDF reshaping.
14852 KFBEAM(JS)=MINT(10+JS)
14853 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
14854 KFABM=IABS(KFBEAM(JS))
14855 KFSBM=ISIGN(1,KFBEAM(JS))
14857 C...Zero flavour content of incoming beam particle.
14861 C... Flavour content of baryon.
14862 IF(KFABM.GT.1000) THEN
14863 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
14864 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
14865 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
14866 C... Flavour content of pi+-, K+-.
14867 ELSEIF(KFABM.EQ.211) THEN
14868 KFIVAL(JS,1)=KFSBM*2
14869 KFIVAL(JS,2)=-KFSBM
14870 ELSEIF(KFABM.EQ.321) THEN
14871 KFIVAL(JS,1)=-KFSBM*3
14872 KFIVAL(JS,2)=KFSBM*2
14873 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
14876 C...Zero initial valence and companion content.
14881 C...Set up colour line tags starting from hard interaction initiators.
14883 C...Reset colour tag array and colour processing flags.
14884 DO 150 I=IMISEP(0)+1,N
14887 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14888 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14890 C... Consider each side in turn.
14895 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
14897 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
14899 CALL PYCTTR(I1,KCS,I2)
14900 IF(MINT(51).NE.0) RETURN
14904 C...Range checking for companion quark pdf large-x param.
14905 IF (MSTP(87).LT.0) THEN
14906 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
14909 ELSEIF (MSTP(87).GT.4) THEN
14910 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
14915 C----------------------------------------------------------------------
14916 C...MODE=0: Generate trial interaction. Return codes:
14917 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
14918 C...IFAIL = 0: Additional interaction generated at PT2.
14919 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
14920 ELSEIF (MODE.EQ.0) THEN
14921 C...Abolute MI max scale = VINT(62)
14922 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
14923 180 IF(MSTP(82).LE.1) THEN
14924 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14925 IF(XT2.LT.VINT(149)) IFAIL=-2
14927 IF(XT2.LE.0.01001D0*VINT(149)) THEN
14930 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14931 & LOG(PYR(0)))-VINT(149)
14934 C...Also exit if below lower limit or if higher trial branching
14936 PT2=0.25D0*VINT(2)*XT2
14937 IF (PT2.LE.PT2CUT) IFAIL=-4
14938 IF (PT2.LE.PT2MX) IFAIL=-5
14939 IF (IFAIL.NE.0) THEN
14943 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
14944 VINT(25)=4D0*PT2/VINT(2)
14947 C...Choose tau and y*. Calculate cos(theta-hat).
14948 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14949 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14950 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14952 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14955 C...New: require shat > 1.
14956 IF(TAU*VINT(2).LT.1D0) GOTO 180
14960 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14961 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14962 CALL PYKMAP(2,MYST,PYR(0))
14963 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14965 C...Check that x not used up. Accept or reject kinematical variables.
14966 X1M=SQRT(TAU)*EXP(VINT(22))
14967 X2M=SQRT(TAU)*EXP(-VINT(22))
14968 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
14969 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14970 CALL PYSIGH(NCHN,SIGS)
14971 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14972 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
14973 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
14975 C...Save if highest PT so far.
14976 IF (PT2.GT.PT2MX) THEN
14982 C----------------------------------------------------------------------
14983 C...MODE=1: Generate and save accepted scattering.
14984 ELSEIF (MODE.EQ.1) THEN
14986 C...Reset K, P, V, and MCT vectors.
14998 C...Choose flavour of reacting partons (and subprocess).
15000 IF (NTRY.GT.50) THEN
15001 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15002 & //'interaction. Giving up!')
15010 ICONMI=ISIG(ICHN,3)
15011 RSIGS=RSIGS-SIGH(ICHN)
15012 IF(RSIGS.LE.0D0) GOTO 230
15015 C...Reassign to appropriate process codes.
15016 230 ISUBMI=ICONMI/10
15017 ICONMI=MOD(ICONMI,10)
15019 C...Choose new quark flavour for annihilation graphs
15020 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15021 SH=VINT(21)*VINT(2)
15022 CALL PYWIDT(21,SH,WDTP,WDTE)
15023 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15024 DO 250 I=1,MDCY(21,3)
15025 KFLF=KFDP(I+MDCY(21,2)-1,1)
15026 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15027 IF(RKFL.LE.0D0) GOTO 260
15029 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15030 IF(KFLF.GE.4) GOTO 240
15031 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15034 ELSEIF(ISUBMI.EQ.53) THEN
15040 C...Final state flavours and colour flow: default values
15047 IF(ISUBMI.EQ.11) THEN
15048 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15050 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15052 ELSEIF(ISUBMI.EQ.12) THEN
15053 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15054 KFL3=ISIGN(KFLF,KFL1)
15058 ELSEIF(ISUBMI.EQ.13) THEN
15059 C...f + fbar -> g + g; th arbitrary
15064 ELSEIF(ISUBMI.EQ.28) THEN
15065 C...f + g -> f + g; th = (p(f)-p(f))**2
15066 IF(KFL1.EQ.21) JS=2
15068 IF(KFL1.EQ.21) KCC=KCC+2
15069 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15070 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15072 ELSEIF(ISUBMI.EQ.53) THEN
15073 C...g + g -> f + fbar; th arbitrary
15074 KCS=(-1)**INT(1.5D0+PYR(0))
15075 KFL3=ISIGN(KFLF,KCS)
15079 ELSEIF(ISUBMI.EQ.68) THEN
15080 C...g + g -> g + g; th arbitrary
15082 KCS=(-1)**INT(1.5D0+PYR(0))
15085 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15086 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15087 & .OR.IABS(KFL4).EQ.5) THEN
15088 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15089 IF (PT2.LE.1.05*RMMAX2) THEN
15090 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15091 & //' created below threshold. Rejected.')
15096 C...Store flavours of scattering.
15104 C...Set flavours and mothers of scattering partons.
15113 K(N+1,3)=MINT(83)+1
15114 K(N+2,3)=MINT(83)+2
15118 C...Store colour connection indices.
15121 IF(KCS.EQ.-1) JC=3-J
15122 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15123 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15124 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15125 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15128 C...Store incoming and outgoing partons in their CM-frame.
15129 SHR=SQRT(VINT(21))*VINT(1)
15132 P(N+2,3)=-0.5D0*SHR
15134 P(N+3,5)=PYMASS(K(N+3,2))
15135 P(N+4,5)=PYMASS(K(N+4,2))
15136 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15140 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15141 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15142 P(N+4,4)=SHR-P(N+3,4)
15145 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15147 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15149 C...Global statistics.
15150 MINT(351)=MINT(351)+1
15151 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15152 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15154 C...Keep track of loose colour ends and information on scattering.
15155 MINT(31)=MINT(31)+1
15157 PT2MI(MINT(36))=PT2
15158 IMISEP(MINT(31))=N+4
15160 IMI(JS,MINT(31),1)=N+JS
15161 IMI(JS,MINT(31),2)=0
15162 XMI(JS,MINT(31))=VINT(40+JS)
15164 C...Update cumulative counters
15165 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15166 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15169 C...Add to list of final state partons
15172 PTPART(NPART+1)=SQRT(PT2)
15173 PTPART(NPART+2)=SQRT(PT2)
15177 NISGEN(1,MINT(31))=0
15178 NISGEN(2,MINT(31))=0
15182 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15183 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15188 C...Finally, assign colour tags to new partons
15190 I1=IMI(JS,MINT(31),1)
15191 I2=IMI(3-JS,MINT(31),1)
15193 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15195 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15197 CALL PYCTTR(I1,KCS,I2)
15198 IF(MINT(51).NE.0) RETURN
15202 C----------------------------------------------------------------------
15203 C...MODE=2: Decide whether quarks in last scattering were valence,
15204 C...companion, or sea.
15205 ELSEIF (MODE.EQ.2) THEN
15209 KFSBM=ISIGN(1,MINT(10+JS))
15210 IFL=K(IMI(JS,MI,1),2)
15212 IF (IABS(IFL).GE.6) THEN
15213 IF (IABS(IFL).EQ.6) THEN
15214 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15218 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15219 C...(Do not include the parton itself in the X rescaling.)
15221 XRSC=X/(VINT(142+JS)+X)
15222 C...Note: XPSVC = x*pdf.
15224 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15228 DO 310 IVC=1,NVC(JS,IFL)
15229 CMP=CMP+XPSVC(IFL,IVC)
15232 C...Decide (Extra factor x cancels in the dvision).
15233 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15235 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15236 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15238 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15239 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15240 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15241 IF(KFIVAL(JS,1).EQ.0) THEN
15242 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15243 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15244 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15245 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15247 C...Count down valence remaining. Do not count current scattering.
15248 DO 340 I1=1,NMI(JS)
15249 IF (I1.EQ.MINT(36)) GOTO 340
15250 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15254 IF(IVNOW.EQ.0) GOTO 330
15257 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15258 IF(KFIVAL(JS,1).EQ.0) THEN
15259 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15262 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15264 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15265 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15269 ELSEIF (RVCS.LE.VAL+SEA) THEN
15270 C...If sea, add opposite sign companion parton. Store X and I.
15271 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15272 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15273 C...Set pointer to companion
15274 IMI(JS,MI,2)=-NVC(JS,-IFL)
15277 C...If companion, decide which one.
15278 IF (NVC(JS,IFL).EQ.0) THEN
15280 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15286 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15287 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15288 C...Find original sea (anti-)quark. Do not consider current scattering.
15290 DO 360 I1=1,NMI(JS)
15291 IF (I1.EQ.MINT(36)) GOTO 360
15292 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15293 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15294 IMI(JS,MI,2)=IMI(JS,I1,1)
15295 IMI(JS,I1,2)=IMI(JS,MI,1)
15298 C...Mark companion "out-kicked".
15299 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15306 C*********************************************************************
15308 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15309 C...Giving the x*f pdf of a companion quark, with its partner at XS,
15310 C...using an approximate gluon density like (1-X)^NPOW/X. The value
15311 C...corresponds to an unrescaled range between 0 and 1-X.
15313 FUNCTION PYFCMP(XC,XS,NPOW)
15315 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15319 C...Parent gluon momentum fraction
15321 IF (Y.GE.1D0) RETURN
15322 C...Common factor (includes factor XC, since PYFCMP=x*f)
15323 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15324 C...Store normalized companion x*f distribution.
15325 IF (NPOW.LE.0) THEN
15326 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15327 ELSEIF (NPOW.EQ.1) THEN
15328 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15329 ELSEIF (NPOW.EQ.2) THEN
15330 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15331 & +3D0*XS*(1D0+XS)*LOG(XS)))
15332 ELSEIF (NPOW.EQ.3) THEN
15333 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15334 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15335 ELSEIF (NPOW.GE.4) THEN
15336 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15337 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15342 C*********************************************************************
15344 C...PYPCMP: Auxiliary to PYPDFU.
15345 C...Giving the momentum integral of a companion quark, with its
15346 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15347 C...The value corresponds to an unrescaled range between 0 and 1-XS.
15349 FUNCTION PYPCMP(XS,NPOW)
15351 DOUBLE PRECISION XS, PYPCMP
15353 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15355 ELSEIF (NPOW.LE.0) THEN
15356 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15357 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15358 ELSEIF (NPOW.EQ.1) THEN
15359 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15360 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15361 ELSEIF (NPOW.EQ.2) THEN
15362 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15363 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15364 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15365 & -3D0*XS*LOG(XS)*(1+XS)))
15366 ELSEIF (NPOW.EQ.3) THEN
15367 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15368 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15369 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15370 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15372 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15373 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15374 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15375 & -6D0*XS*LOG(XS)*(1D0+XS)))
15380 C*********************************************************************
15383 C...Rearranges contents of the HEPEUP commonblock so that
15384 C...mothers precede daughters and daughters of a decay are
15385 C...listed consecutively.
15389 C...Double precision and integer declarations.
15390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15391 IMPLICIT INTEGER(I-N)
15393 C...User process event common block.
15395 PARAMETER (MAXNUP=500)
15396 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15397 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15398 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15399 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15400 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15404 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15405 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15406 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15408 C...Check whether a rearrangement is required.
15411 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15414 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15418 C...Find the new order that particles should have.
15424 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15429 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15430 IF(NNEW.NE.NUP) THEN
15432 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15436 C...Copy old info into temporary storage.
15440 MOTUPT(1,I)=MOTHUP(1,I)
15441 MOTUPT(2,I)=MOTHUP(2,I)
15442 ICOUPT(1,I)=ICOLUP(1,I)
15443 ICOUPT(2,I)=ICOLUP(2,I)
15447 VTIUPT(I)=VTIMUP(I)
15448 SPIUPT(I)=SPINUP(I)
15451 C...Copy info back into HEPEUP in right order.
15454 IDUP(I)=IDUPT(IOLD)
15455 ISTUP(I)=ISTUPT(IOLD)
15459 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15460 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15462 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15464 MOTHUP(1,I)=MOTHUP(2,I)
15467 ICOLUP(1,I)=ICOUPT(1,IOLD)
15468 ICOLUP(2,I)=ICOUPT(2,IOLD)
15470 PUP(J,I)=PUPT(J,IOLD)
15472 VTIMUP(I)=VTIUPT(IOLD)
15473 SPINUP(I)=SPIUPT(IOLD)
15477 c...If incoming particles are massive recalculate to put them massless.
15478 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15479 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15480 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15481 PUP(4,1)=0.5D0*PPLUS
15484 PUP(4,2)=0.5D0*PMINUS
15492 C*********************************************************************
15495 C...Administers the generation of successive final-state showers
15496 C...in external processes.
15498 SUBROUTINE PYADSH(NFIN)
15500 C...Double precision and integer declarations.
15501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15502 IMPLICIT INTEGER(I-N)
15503 INTEGER PYK,PYCHGE,PYCOMP
15504 C...Parameter statement for maximum size of showers.
15505 PARAMETER (MAXNUR=1000)
15507 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15508 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15509 COMMON/PYCTAG/NCT,MCT(4000,2)
15510 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15512 COMMON/PYINT1/MINT(400),VINT(400)
15513 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15515 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15517 C...Set primary vertex.
15519 V(MINT(83)+5,J)=0D0
15520 V(MINT(83)+6,J)=0D0
15521 V(MINT(84)+1,J)=0D0
15522 V(MINT(84)+2,J)=0D0
15525 C...Isolate systems of particles with the same mother.
15528 DO 140 I=MINT(84)+3,NFIN
15530 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15537 C...Set production vertices.
15538 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15545 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15548 IF(MSTP(125).GE.1) THEN
15556 C...End loop over systems. Return if no showers to be performed.
15557 IBEG(NSYS+1)=NFIN+1
15558 IF(MSTP(71).LE.0) RETURN
15560 C...Loop through systems of particles; check that sensible size.
15562 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15563 IF(MINT(35).LE.1) THEN
15564 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15566 ELSEIF(NSIZ.LE.1) THEN
15567 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15569 ELSEIF(NSIZ.GT.80) THEN
15570 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15575 C...Save status codes and daughters of showering particles; reset them.
15582 IF(K(I,1).GT.10) THEN
15584 IF(KSAV(II,1).EQ.14) K(I,1)=3
15586 IF(KSAV(II,1).LE.10) THEN
15587 ELSEIF(K(I,1).EQ.1) THEN
15593 KSAV(II,4)=MOD(K(I,4),MSTU(5))
15594 KSAV(II,5)=MOD(K(I,5),MSTU(5))
15595 K(I,4)=K(I,4)-KSAV(II,4)
15596 K(I,5)=K(I,5)-KSAV(II,5)
15599 PSUM(J)=PSUM(J)+P(I,J)
15603 C...Perform shower.
15604 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
15606 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
15608 IF(MINT(35).LE.1) THEN
15610 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
15612 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
15615 C...For external processes, first call, also ISR partons radiate.
15616 C...Can use existing PYPART list, removing partons that radiate later.
15617 ELSEIF(ISYS.EQ.1) THEN
15620 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
15622 IPART(NPARTN)=IPART(II)
15623 PTPART(NPARTN)=PTPART(II)
15627 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
15629 C...For subsequent calls use the systems excluded above.
15635 PTPART(II)=0.5D0*QMAX
15637 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
15640 C...Look up showered copies of original showering particles.
15644 C...Particles without daughters need not be studied.
15645 IF(KSAV(II,1).LE.10) GOTO 260
15646 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
15647 ELSEIF(K(I,1).EQ.11) THEN
15648 190 IMV=MOD(K(IMV,4),MSTU(5))
15649 IF(K(IMV,1).EQ.11) GOTO 190
15651 KDA1=MOD(K(I,4),MSTU(5))
15653 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
15655 KDA2=MOD(K(I,5),MSTU(5))
15657 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
15660 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
15663 KDA1=MOD(K(I3,4),MSTU(5))
15665 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
15667 KDA2=MOD(K(I3,5),MSTU(5))
15669 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
15675 C...Restore daughter info of original partons to showered copies.
15676 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
15677 IF(KSAV(II,1).LE.10) THEN
15678 ELSEIF(K(I,1).EQ.1) THEN
15679 K(IMV,4)=KSAV(II,4)
15680 K(IMV,5)=KSAV(II,5)
15682 K(IMV,4)=K(IMV,4)+KSAV(II,4)
15683 K(IMV,5)=K(IMV,5)+KSAV(II,5)
15686 C...Reset mother info of existing daughters to showered copies.
15687 DO 210 I3=IBEG(ISYS+1),NFIN
15688 IF(K(I3,3).EQ.I) K(I3,3)=IMV
15689 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
15690 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
15691 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
15695 C...Boost all original daughters to new frame of showered copy.
15696 C...Also update their colour tags.
15699 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
15701 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
15703 BETA(J)=FAC*BETA(J)
15705 DO 250 I3=IBEG(ISYS+1),NFIN
15708 IF(MSTP(128).LE.0) THEN
15709 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
15710 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
15712 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
15713 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
15714 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
15717 IF(IMO.EQ.IMV) THEN
15718 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
15719 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
15720 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
15721 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
15729 C...End of loop over showering systems
15735 C*********************************************************************
15738 C...Interface to UPVETO, which allows user to veto event generation
15739 C...on the parton level, after parton showers but before multiple
15740 C...interactions, beam remnants and hadronization is added.
15742 SUBROUTINE PYVETO(IVETO)
15744 C...All real arithmetic in double precision.
15745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15746 C...Three Pythia functions return integers, so need declaring.
15747 INTEGER PYK,PYCHGE,PYCOMP
15749 C...PYTHIA commonblocks.
15750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15751 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15752 COMMON/PYINT1/MINT(400),VINT(400)
15753 SAVE /PYJETS/,/PYPARS/,/PYINT1/
15754 C...HEPEVT commonblock.
15755 PARAMETER (NMXHEP=4000)
15756 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15757 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
15758 DOUBLE PRECISION PHEP,VHEP
15761 DIMENSION IRESO(100)
15763 C...Define longitudinal boost from initiator rest frame to cm frame.
15764 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
15765 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
15767 C... Reset counters.
15772 C...First pass: identify final locations of resonances
15773 C...and of their daughters before showering.
15774 DO 150 I=MINT(84)+3,N
15778 C...Skip shower CM frame documentation lines.
15779 IF(K(I,2).EQ.94) THEN
15781 C... Store a new intermediate product, when mother in documentation.
15782 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
15783 & K(I,3).LE.MINT(84)) THEN
15789 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
15791 C... Store a new intermediate product, when mother in main section.
15792 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
15793 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
15799 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
15801 C...Update a product when a new copy of it has been created.
15804 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(I-1-IHIST)
15807 IF(IHIST.EQ.IRESO(IRI)) IR=IRI
15809 C...Flavours must match, and exclude gluon and photon emission.
15810 IF(K(IHIST,2).NE.K(I,2)) IR=0
15811 IF(IR.GT.0.AND.I.LT.N) THEN
15812 IF(K(I+1,3).EQ.K(I,3).AND.(K(I+1,2).EQ.21.OR.
15813 & K(I+1,2).EQ.22)) IR=0
15823 IF(ISTORE.EQ.1) THEN
15824 C...Copy parton info, boosting momenta along z axis to cm frame.
15829 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
15830 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
15832 C...Store one mother. Rest of history and vertex info zeroed.
15844 C...Second pass: identify current set of "final" partons.
15845 DO 200 I=MINT(84)+3,N
15849 C...Store a final parton.
15850 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
15854 C..Trace it back through shower, to check if from documented particle.
15858 IF(IHIST.GT.MINT(84)) THEN
15859 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
15861 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
15865 IF(IMOTH.EQ.0) GOTO 160
15869 IF(ISTORE.EQ.1) THEN
15870 C...Copy parton info, boosting momenta along z axis to cm frame.
15875 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
15876 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
15878 C...Store one mother. Rest of history and vertex info zeroed.
15890 C...Call user-written routine to decide whether to keep events.
15897 C*********************************************************************
15900 C...Allows resonances to decay (including parton showers for hadronic
15903 SUBROUTINE PYRESD(IRES)
15905 C...Double precision and integer declarations.
15906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15907 IMPLICIT INTEGER(I-N)
15908 INTEGER PYK,PYCHGE,PYCOMP
15909 C...Parameter statement to help give large particle numbers.
15910 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15911 &KEXCIT=4000000,KDIMEN=5000000)
15912 C...Parameter statement for maximum size of showers.
15913 PARAMETER (MAXNUR=1000)
15915 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15916 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15917 COMMON/PYCTAG/NCT,MCT(4000,2)
15918 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15919 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15920 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15921 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15923 COMMON/PYINT1/MINT(400),VINT(400)
15924 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15925 COMMON/PYINT4/MWID(500),WIDS(500,5)
15926 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
15927 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
15928 C...Local arrays and complex and character variables.
15929 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
15930 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
15931 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
15932 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
15934 COMPLEX FGK,HA(6,6),HC(6,6)
15936 CHARACTER CODE*9,MASS*9
15938 C...The F, Xi and Xj functions of Gunion and Kunszt
15939 C...(Phys. Rev. D33, 665, plus errata from the authors).
15940 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
15941 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
15942 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
15943 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
15944 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
15945 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
15946 &2D0*(D34/D56+D56/D34))
15948 C...Some general constants.
15951 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
15955 GMMZ=PMAS(23,1)*PMAS(23,2)
15957 GMMW=PMAS(24,1)*PMAS(24,2)
15960 C...Boost and rotate to rest frame of incoming partons,
15961 C...to get proper amount of smearing of decay angles.
15965 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
15966 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
15967 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
15968 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
15969 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
15970 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
15971 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
15972 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
15973 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
15976 C...Reset original resonance configuration.
15981 C...Define initial one, two or three objects for subprocess.
15985 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15986 IREF(1,1)=MINT(84)+2+ISET(ISUB)
15987 IREF(1,4)=MINT(83)+6+ISET(ISUB)
15989 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
15990 IREF(1,1)=MINT(84)+1+ISET(ISUB)
15991 IREF(1,2)=MINT(84)+2+ISET(ISUB)
15992 IREF(1,4)=MINT(83)+5+ISET(ISUB)
15993 IREF(1,5)=MINT(83)+6+ISET(ISUB)
15995 ELSEIF(ISET(ISUB).EQ.5) THEN
15996 IREF(1,1)=MINT(84)+3
15997 IREF(1,2)=MINT(84)+4
15998 IREF(1,3)=MINT(84)+5
15999 IREF(1,4)=MINT(83)+7
16000 IREF(1,5)=MINT(83)+8
16001 IREF(1,6)=MINT(83)+9
16005 C...Define original resonance for odd cases.
16008 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16010 IF(IHDEC.EQ.1) ISUB=3
16012 IREF(1,4)=K(IRES,3)
16014 IF(IREF(1,4).GT.MINT(84)) THEN
16015 110 ITMPMO=IREF(1,4)
16016 IF(K(ITMPMO,2).EQ.94) THEN
16017 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16018 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16019 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16021 IREF(1,4)=K(ITMPMO,3)
16025 IF(IREF(1,4).GT.MINT(84)) THEN
16028 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16029 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16032 EMATCH=ABS(P(II,4)-P(IREF14,4))
16039 C...Check if initial resonance has been moved (in resonance + jet).
16041 IF(IREF(1,JT).GT.0) THEN
16042 IF(K(IREF(1,JT),1).GT.10) THEN
16043 KFA=IABS(K(IREF(1,JT),2))
16044 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16045 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16046 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16047 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16048 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16050 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16051 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16053 DO 130 I=IREF(1,JT)+1,N
16054 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16057 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16058 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16059 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16060 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16062 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16063 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16068 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16069 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16075 C...Set decay vertex for initial resonances
16078 V(IREF(1,JT),I)=0D0
16082 C...Loop over decay history.
16088 IF(IREF(IP,2).EQ.0) JTMAX=1
16089 IF(IREF(IP,3).NE.0) JTMAX=3
16093 C...Check for Higgs which appears as decay product of user-process.
16096 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16098 IF(IHDEC.EQ.1) ISUB=3
16101 C...Start treatment of one, two or three resonances in parallel.
16113 C...Check whether particle can/is allowed to decay.
16114 IF(ID.EQ.0) GOTO 330
16117 IF(MWID(KCA).EQ.0) GOTO 330
16118 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16119 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16120 & KFA.EQ.18) IT4=IT4+1
16121 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16122 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16124 C...Choose lifetime and determine decay vertex.
16125 IF(K(ID,1).EQ.5) THEN
16127 ELSEIF(K(ID,1).NE.4) THEN
16128 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16131 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16134 C...Determine whether decay allowed or not.
16136 IF(MSTJ(22).EQ.2) THEN
16137 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16138 ELSEIF(MSTJ(22).EQ.3) THEN
16139 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16140 ELSEIF(MSTJ(22).EQ.4) THEN
16141 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16142 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16144 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16149 C...Info for selection of decay channel: sign, pairings.
16150 IF(KCHG(KCA,3).EQ.0) THEN
16153 IPM=(5-ISIGN(1,K(ID,2)))/2
16156 IF(JTMAX.EQ.2) THEN
16157 KFB=IABS(K(IREF(IP,3-JT),2))
16158 ELSEIF(JTMAX.EQ.3) THEN
16160 KFB=IABS(K(IREF(IP,JT2),2))
16161 IF(KFB.NE.KFA) THEN
16162 JT2=JT+2-3*((JT+1)/3)
16163 KFB=IABS(K(IREF(IP,JT2),2))
16167 C...Select decay channel.
16168 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16169 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16170 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16171 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16172 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16173 IF(WDTE0S.LE.0D0) GOTO 330
16177 IDC=IDL+MDCY(KCA,2)-1
16178 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16179 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16180 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16182 C...Read out flavours and colour charges of decay channel chosen.
16183 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16184 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16185 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16186 KFC1A=PYCOMP(IABS(KFL1(JT)))
16187 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16188 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16189 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16190 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16191 KFC2A=PYCOMP(IABS(KFL2(JT)))
16192 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16193 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16194 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16195 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16197 IF(KFL3(JT).NE.0) THEN
16198 KFC3A=PYCOMP(IABS(KFL3(JT)))
16199 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16200 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16201 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16204 C...Set/save further info on channel.
16206 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16208 HGZ(JT,1)=VINT(111)
16209 HGZ(JT,2)=VINT(112)
16210 HGZ(JT,3)=VINT(114)
16213 C...Select masses; to begin with assume resonances narrow.
16218 KFLW=IABS(KFL1(JT))
16220 ELSEIF(I.EQ.2) THEN
16221 KFLW=IABS(KFL2(JT))
16223 ELSEIF(I.EQ.3) THEN
16224 IF(KFL3(JT).EQ.0) GOTO 220
16225 KFLW=IABS(KFL3(JT))
16228 P(N+I,5)=PMAS(KCW,1)
16230 C...This prevents SUSY/t particles from becoming too light.
16231 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16232 PMMN(I)=PMAS(KCW,1)
16233 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16234 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16235 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16236 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16237 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16238 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16239 PMMN(I)=MIN(PMMN(I),PMSUM)
16243 ELSEIF(KFLW.EQ.6) THEN
16244 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16248 C...Check which two out of three are widest.
16251 PWID1=PMAS(KFC1A,2)
16252 PWID2=PMAS(KFC2A,2)
16253 KFLW1=IABS(KFL1(JT))
16254 KFLW2=IABS(KFL2(JT))
16255 IF(KFL3(JT).NE.0) THEN
16256 PWID3=PMAS(KFC3A,2)
16257 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16260 KFLW1=IABS(KFL3(JT))
16261 ELSEIF(PWID3.GT.PWID2) THEN
16264 KFLW2=IABS(KFL3(JT))
16268 C...If all narrow then only check that masses consistent.
16269 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16270 & PWID2.LT.PARP(41))) THEN
16272 C....Handle near degeneracy cases.
16273 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16274 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16275 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16276 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16280 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16281 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16284 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16285 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16290 C...For three wide resonances select narrower of three
16291 C...according to BW decoupled from rest.
16294 IF(KFL3(JT).NE.0) THEN
16295 IWID3=6-IWID1-IWID2
16296 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16300 P(N+IWID3,5)=PYMASS(KFLW3)
16301 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16302 PMTOT=PMTOT-P(N+IWID3,5)
16304 C...Select other two correlated within remaining phase space.
16308 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16309 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16310 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16315 CKIN(49)=PMMN(IWID1)
16316 CKIN(50)=PMMN(IWID2)
16317 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16322 IF(MINT(51).EQ.1) GOTO 720
16325 C...Begin fill decay products, with colour flow for coloured objects.
16331 C...1) Three-body decays of SUSY particles (plus special case top).
16332 IF(KFL3(JT).NE.0) THEN
16350 C...Set colour flow for t -> W + b + Z.
16354 IF(KCQM(JT).EQ.-1) ISID=5
16356 K(ID,ISID)=K(ID,ISID)+IDAU
16357 K(IDAU,ISID)=MSTU(5)*ID
16359 C...Set colour flow in three-body decays - programmed as special cases.
16361 ELSEIF(KFC2A.LE.6) THEN
16365 IF(KFL2(JT).LT.0) ISID=5
16366 K(N+2,ISID)=MSTU(5)*(N+3)
16367 K(N+3,9-ISID)=MSTU(5)*(N+2)
16368 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16369 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16370 & .AND.KFL3(JT).NE.0) THEN
16371 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16372 C...3-body decays of squarks to colour singlets plus one quark
16373 IF (KQSUMA.EQ.1) THEN
16376 IF (KCQ1(JT).NE.0) IQ=1
16377 IF (KCQ2(JT).NE.0) IQ=2
16378 IF (KCQ3(JT).NE.0) IQ=3
16380 IF (K(N+IQ,2).LT.0) ISID=5
16382 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16383 K(N+IQ,ISID)=MSTU(5)*ID
16387 IF(KFL1(JT).EQ.KSUSY1+21) THEN
16392 IF(KFL2(JT).LT.0) ISID=5
16393 K(N+1,ISID)=MSTU(5)*(N+2)
16394 K(N+1,9-ISID)=MSTU(5)*(N+3)
16395 K(N+2,ISID)=MSTU(5)*(N+1)
16396 K(N+3,9-ISID)=MSTU(5)*(N+1)
16398 IF(KFA.EQ.KSUSY1+21) THEN
16402 IF(KFL2(JT).LT.0) ISID=5
16403 K(ID,ISID)=K(ID,ISID)+(N+2)
16404 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
16405 K(N+2,ISID)=MSTU(5)*ID
16406 K(N+3,9-ISID)=MSTU(5)*ID
16413 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
16414 & IABS(KCQ2(JT)).EQ.1) THEN
16418 IF(KFL2(JT).LT.0) ISID=5
16419 K(N+2,ISID)=MSTU(5)*(N+3)
16420 K(N+3,9-ISID)=MSTU(5)*(N+2)
16423 C...Set colour flow in three-body decays with baryon number violation.
16424 C...Neutralino and chargino decays first.
16425 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
16426 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
16427 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
16428 K(N+4,4)=ITJUNC(JT)*MSTU(5)
16429 C...Insert junction to keep track of colours.
16430 IF(KCQ1(JT).NE.0) K(N+1,1)=3
16431 IF(KCQ2(JT).NE.0) K(N+2,1)=3
16432 IF(KCQ3(JT).NE.0) K(N+3,1)=3
16433 C...Set special junction codes:
16437 C...Order decay products by invariant mass. (will be used in PYSTRF).
16438 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)-
16439 & P(N+1,3)*P(N+2,3)
16440 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)-
16441 & P(N+1,3)*P(N+3,3)
16442 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)-
16443 & P(N+2,3)*P(N+3,3)
16444 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
16445 K(N+4,4)=N+3+K(N+4,4)
16446 K(N+4,5)=N+1+MSTU(5)*(N+2)
16447 ELSEIF(PM13.LT.PM23) THEN
16448 K(N+4,4)=N+2+K(N+4,4)
16449 K(N+4,5)=N+1+MSTU(5)*(N+3)
16451 K(N+4,4)=N+1+K(N+4,4)
16452 K(N+4,5)=N+2+MSTU(5)*(N+3)
16458 C...Connect daughters to junction.
16462 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
16464 C...Particle counter should be stepped up one extra for junction.
16468 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
16469 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
16470 K(N+4,4)=ITJUNC(JT)*MSTU(5)
16471 C...Insert junction to keep track of colours.
16472 IF(KCQ1(JT).NE.0) K(N+1,1)=3
16473 IF(KCQ2(JT).NE.0) K(N+2,1)=3
16474 IF(KCQ3(JT).NE.0) K(N+3,1)=3
16485 C...Start by connecting all daughters to junction.
16486 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
16487 C...Only consider colour topologies with off shell resonances.
16488 RMQ1=PMAS(PYCOMP(K(II,2)),1)
16489 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
16490 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
16491 IF (RMGLU-RMQ1.LT.RMRES) THEN
16492 C...Calculate propagators for each colour topology.
16493 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
16494 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
16495 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
16499 CTMSUM=CTMSUM+CTM2(II-N)
16501 CTMSUM=PYR(0)*CTMSUM
16502 C...Select colour topology J, with most off shell least likely.
16505 CTMSUM=CTMSUM-CTM2(J)
16506 IF (CTMSUM.GT.0D0) GOTO 300
16507 C...The lucky winner gets its colour (anti-colour) directly from gluino.
16508 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
16509 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
16510 C...The other gluino colour is connected to junction
16511 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
16513 K(N+4,4)=K(N+4,4)+ID
16514 C...Lastly, connect junction to remaining daughters.
16515 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
16516 C...Particle counter should be stepped up one extra for junction.
16520 C...Update particle counter.
16523 C...2) Everything else two-body decay.
16525 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
16530 C...First set colour flow as if mother colour singlet.
16531 IF(KCQ1(JT).NE.0) THEN
16533 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
16534 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
16536 IF(KCQ2(JT).NE.0) THEN
16538 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
16539 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
16541 C...Then redirect colour flow if mother (anti)triplet.
16542 IF(KCQM(JT).EQ.0) THEN
16543 ELSEIF(KCQM(JT).NE.2) THEN
16545 IF(KCQM(JT).EQ.-1) ISID=5
16547 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
16548 K(ID,ISID)=K(ID,ISID)+IDAU
16549 K(IDAU,ISID)=MSTU(5)*ID
16550 C...Then redirect colour flow if mother octet.
16551 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
16553 IF(KCQ1(JT).EQ.0) IDAU=N
16554 K(ID,4)=K(ID,4)+IDAU
16555 K(ID,5)=K(ID,5)+IDAU
16556 K(IDAU,4)=MSTU(5)*ID
16557 K(IDAU,5)=MSTU(5)*ID
16560 IF(KCQ1(JT).EQ.-1) ISID=5
16561 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
16562 K(ID,ISID)=K(ID,ISID)+(N-1)
16563 K(ID,9-ISID)=K(ID,9-ISID)+N
16564 K(N-1,ISID)=MSTU(5)*ID
16565 K(N,9-ISID)=MSTU(5)*ID
16568 C...Insert junction
16569 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
16571 C...~q* mother: type 3 junction. ~q mother: type 4.
16572 ITJUNC(JT)=(7+KCQM(JT))/2
16573 C...Specify junction KF and set colour flow from junction
16577 C...Junction type encoded together with mother:
16578 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
16579 K(N,5)=N-1+MSTU(5)*(N-2)
16580 C...Zero P and V for junction (V filled later)
16585 C...Set colour flow from mother to junction
16586 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
16587 C...Set colour flow from daughters to junction
16591 C...(Anti-)colour mother is junction.
16592 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
16597 C...End loop over resonances for daughter flavour and mass selection.
16599 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
16601 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
16602 & KFL1(JT).EQ.0) THEN
16603 WRITE(CODE,'(I9)') K(ID,2)
16604 WRITE(MASS,'(F9.3)') P(ID,5)
16605 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
16606 & CODE//' with mass'//MASS)
16612 C...Check for allowed combinations. Skip if no decays.
16613 IF(JTMAX.EQ.1) THEN
16614 IF(KDCY(1).EQ.0) GOTO 710
16615 ELSEIF(JTMAX.EQ.2) THEN
16616 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
16617 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
16618 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
16619 ELSEIF(JTMAX.EQ.3) THEN
16620 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
16621 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
16622 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
16623 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
16624 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
16625 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
16626 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
16629 C...Special case: matrix element option for Z0 decay to quarks.
16630 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
16631 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
16633 C...Check consistency of MSTJ options set.
16634 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
16636 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
16639 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
16641 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
16646 C...Select alpha_strong behaviour.
16649 MSTU(111)=MSTJ(108)
16650 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
16652 PARU(112)=PARJ(121)
16653 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
16655 C...Find axial fraction in total cross section for scalar gluon model.
16657 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
16658 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
16659 POLL=1D0-PARJ(131)*PARJ(132)
16660 SFF=1D0/(16D0*XW*XW1)
16661 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
16662 & (PARJ(123)*PARJ(124))**2)
16663 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
16665 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
16666 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
16667 & (PARJ(132)-PARJ(131)))
16670 QF=KCHG(KFLC,1)/3D0
16672 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
16673 & 1D0-(2D0*PMQ/P(ID,5))**2))
16674 VF=SIGN(1D0,QF)-4D0*QF*XW
16675 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
16676 & VF**2*HF1W)+VQ**3*HF1W
16677 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
16680 C...Choice of jet configuration.
16681 CALL PYXJET(P(ID,5),NJET,CUT)
16685 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
16686 ELSEIF(NJET.EQ.3) THEN
16687 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
16692 C...Fill jet configuration; return if incorrect kinematics.
16694 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
16695 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
16696 ELSEIF(NJET.EQ.2) THEN
16697 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
16698 ELSEIF(NJET.EQ.3) THEN
16699 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
16700 ELSEIF(KFLN.EQ.21) THEN
16701 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
16704 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
16707 IF(MSTU(24).NE.0) THEN
16714 C...Angular orientation according to matrix element.
16715 IF(MSTJ(106).EQ.1) THEN
16716 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
16717 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
16719 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
16720 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
16723 C...Boost partons to Z0 rest frame.
16724 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
16725 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
16727 C...Mark decayed resonance and add documentation lines,
16729 IDOC=MINT(83)+MINT(4)
16731 I1=MINT(83)+MINT(4)+1
16733 IF(MSTP(128).GE.1) K(I,3)=ID
16734 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
16745 C...Generate parton shower.
16746 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
16747 CALL PYSHOW(N-1,N,P(ID,5))
16748 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
16752 PTPART(1)=0.5D0*P(ID,5)
16753 PTPART(2)=PTPART(1)
16755 IF(K(N-1,2).GT.0) THEN
16762 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
16765 C... End special case for Z0: skip ahead.
16771 C...Order incoming partons and outgoing resonances.
16772 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
16775 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
16776 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
16777 & ILIN(1)=2*MINT(84)+3-ILIN(1)
16778 ILIN(2)=2*MINT(84)+3-ILIN(1)
16780 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16784 IF(K(IREF(IP,1),2).EQ.23) IORD=2
16785 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
16786 IAKIPD=IABS(K(IREF(IP,IORD),2))
16787 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
16788 IF(KDCY(IORD).EQ.0) IORD=3-IORD
16790 C...Order decay products of resonances.
16791 DO 370 JT=IORD,3-IORD,3-2*IORD
16792 IF(KDCY(JT).EQ.0) THEN
16793 ILIN(IMAX+1)=NSD(JT)
16795 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
16796 ILIN(IMAX+1)=N+2*JT-1
16797 ILIN(IMAX+2)=N+2*JT
16799 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
16800 K(N+2*JT,2)=K(NSD(JT)+2,2)
16802 ILIN(IMAX+1)=N+2*JT
16804 ILIN(IMAX+2)=N+2*JT-1
16806 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
16807 K(N+2*JT,2)=K(NSD(JT)+2,2)
16811 C...Find charge, isospin, left- and righthanded couplings.
16816 KFA=IABS(K(ILIN(I),2))
16817 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
16818 COUP(I,1)=KCHG(KFA,1)/3D0
16819 COUP(I,2)=(-1)**MOD(KFA,2)
16820 COUP(I,4)=-2D0*COUP(I,1)*XWV
16821 COUP(I,3)=COUP(I,2)+COUP(I,4)
16824 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
16825 IF(ISUB.EQ.22) THEN
16828 IF(I.EQ.5) I1=3-IORD
16831 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
16832 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
16833 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
16838 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
16839 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
16840 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
16841 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
16843 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
16847 C...Select angular orientation type - Z'/W' only.
16849 IF(ISUB.EQ.141) THEN
16850 IF(PYR(0).LT.PARU(130)) MZPWP=1
16852 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
16853 IAKIR=IABS(K(IREF(2,2),2))
16854 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
16855 IF(IAKIR.LE.20) MZPWP=2
16857 IF(IP.GE.3) MZPWP=2
16858 ELSEIF(ISUB.EQ.142) THEN
16859 IF(PYR(0).LT.PARU(136)) MZPWP=1
16861 IAKIR=IABS(K(IREF(2,2),2))
16862 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
16863 IF(IAKIR.LE.20) MZPWP=2
16865 IF(IP.GE.3) MZPWP=2
16868 C...Select random angles (begin of weighting procedure).
16869 430 DO 440 JT=1,JTMAX
16870 IF(KDCY(JT).EQ.0) GOTO 440
16871 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
16872 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
16873 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
16876 CTHE(JT)=2D0*PYR(0)-1D0
16877 PHI(JT)=PARU(2)*PYR(0)
16881 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
16882 C...Construct massless four-vectors.
16891 IF(KDCY(JT).EQ.0) GOTO 470
16893 P(N+2*JT-1,3)=0.5D0*P(ID,5)
16894 P(N+2*JT-1,4)=0.5D0*P(ID,5)
16895 P(N+2*JT,3)=-0.5D0*P(ID,5)
16896 P(N+2*JT,4)=0.5D0*P(ID,5)
16897 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
16898 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
16901 C...Store incoming and outgoing momenta, with random rotation to
16902 C...avoid accidental zeroes in HA expressions.
16906 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
16907 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
16908 P(N+4+I,5)=P(ILIN(I),5)
16910 P(N+4+I,J)=P(ILIN(I),J)
16913 500 THERR=ACOS(2D0*PYR(0)-1D0)
16914 PHIRR=PARU(2)*PYR(0)
16915 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
16917 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
16918 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
16925 C...Calculate internal products.
16926 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
16927 & ISUB.EQ.142) THEN
16928 DO 540 I1=IMIN,IMAX-1
16929 DO 530 I2=I1+1,IMAX
16930 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
16931 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
16932 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
16933 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
16934 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
16935 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
16936 HC(I1,I2)=CONJG(HA(I1,I2))
16937 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
16938 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
16939 HA(I2,I1)=-HA(I1,I2)
16940 HC(I2,I1)=-HC(I1,I2)
16945 C...Calculate four-products.
16952 DO 580 I1=IMIN,IMAX-1
16953 DO 570 I2=I1+1,IMAX
16954 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
16955 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
16956 PKK(I2,I1)=PKK(I1,I2)
16962 KFAGM=IABS(IREF(IP,7))
16963 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
16964 C...Isotropic decay selected by user.
16968 ELSEIF(JTMAX.EQ.3) THEN
16969 C...Isotropic decay when three mother particles.
16973 ELSEIF(IT4.GE.1) THEN
16974 C... Isotropic decay t -> b + W etc for 4th generation q and l.
16978 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
16979 & IREF(IP,7).EQ.36) THEN
16980 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
16981 C...CP-odd case added by Kari Ertresvag Myklevoll.
16982 C...Now also with mixed Higgs CP-states
16984 IF(IP.EQ.1) WTMAX=SH**2
16985 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
16986 KFA=IABS(K(IREF(IP,1),2))
16988 IF((KFA.EQ.23.OR.KFA.EQ.24).AND.MSTP(25).GE.3) THEN
16989 C...For mixed CP states need epsilon product.
17006 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17007 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17008 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17009 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17010 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17011 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17012 & P22*P30*P41+P13*P22*P31*P40
17013 C...For mixed CP states need gauge boson masses.
17014 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17015 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17016 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17017 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17023 KFLF1A=IABS(KFL1(1))
17024 EF1=KCHG(KFLF1A,1)/3D0
17025 AF1=SIGN(1D0,EF1+0.1D0)
17026 VF1=AF1-4D0*EF1*XWV
17027 KFLF2A=IABS(KFL1(2))
17028 EF2=KCHG(KFLF2A,1)/3D0
17029 AF2=SIGN(1D0,EF2+0.1D0)
17030 VF2=AF2-4D0*EF2*XWV
17031 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17032 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17035 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17036 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17037 ELSEIF(MSTP(25).LE.2) THEN
17039 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17040 & -2*PKK(3,4)*PKK(5,6)
17041 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17042 & (PKK(3,4)*PKK(5,6))
17043 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17044 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17046 C...Mixed CP states.
17047 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17048 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17049 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17050 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17051 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17052 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17053 & +PKK(3,4)*PKK(5,6)
17054 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17055 & +VA12AS*PKK(3,4)*PKK(5,6)
17056 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17057 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17058 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17059 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17063 ELSEIF(KFA.EQ.24) THEN
17064 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17067 WT=16D0*PKK(3,5)*PKK(4,6)
17068 ELSEIF(MSTP(25).LE.2) THEN
17070 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17071 & -2*PKK(3,4)*PKK(5,6)
17072 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17073 & (PKK(3,4)*PKK(5,6))
17074 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17075 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17077 C...Mixed CP states.
17078 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17079 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17080 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17081 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17082 & +PKK(3,4)*PKK(5,6)
17083 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17084 & +PKK(3,4)*PKK(5,6)
17085 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17086 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17087 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17088 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17091 C...No angular correlations in other Higgs decays.
17096 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17097 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17099 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17101 IF(MOD(KFAGM,2).EQ.0) THEN
17109 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17110 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17111 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17112 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17114 ELSEIF(ISUB.EQ.1) THEN
17115 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17116 EI=KCHG(IABS(MINT(15)),1)/3D0
17117 AI=SIGN(1D0,EI+0.1D0)
17119 EF=KCHG(IABS(KFL1(1)),1)/3D0
17120 AF=SIGN(1D0,EF+0.1D0)
17123 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17124 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17125 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17126 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17127 & (VI**2+AI**2)*VINT(114)*VF**2)
17128 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17129 & 4D0*VI*AI*VINT(114)*VF*AF)
17130 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17131 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17132 WTMAX=2D0*(WT1+ABS(WT3))
17134 ELSEIF(ISUB.EQ.2) THEN
17135 C...Angular weight for W+/- -> 2 quarks/leptons.
17136 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17137 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17138 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17139 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17142 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17143 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17144 C...-> gluon/gamma + 2 quarks/leptons.
17145 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17146 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17147 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17148 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17149 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17150 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17151 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17152 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17153 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17154 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17155 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17156 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17157 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17158 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17159 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17160 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17162 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17163 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17164 C...-> gluon/gamma + 2 quarks/leptons.
17165 WT=PKK(1,3)**2+PKK(2,4)**2
17166 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17168 ELSEIF(ISUB.EQ.22) THEN
17169 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17170 S34=P(IREF(IP,IORD),5)**2
17171 S56=P(IREF(IP,3-IORD),5)**2
17172 TI=PKK(1,3)+PKK(1,4)+S34
17173 UI=PKK(1,5)+PKK(1,6)+S56
17176 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17177 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17178 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17179 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17180 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17181 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17182 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17183 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17186 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17187 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17188 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17189 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17190 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17191 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17192 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17195 ELSEIF(ISUB.EQ.23) THEN
17196 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17197 D34=P(IREF(IP,IORD),5)**2
17198 D56=P(IREF(IP,3-IORD),5)**2
17199 DT=PKK(1,3)+PKK(1,4)+D34
17200 DU=PKK(1,5)+PKK(1,6)+D56
17201 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17202 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17203 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17204 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17206 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17207 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17208 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17209 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17210 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17211 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17213 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17214 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17215 C...(or H0, or A0).
17216 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17217 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17218 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17219 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17220 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17222 ELSEIF(ISUB.EQ.25) THEN
17223 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17224 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17225 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17226 D34=P(IREF(IP,IORD),5)**2
17227 D56=P(IREF(IP,3-IORD),5)**2
17228 DT=PKK(1,3)+PKK(1,4)+D34
17229 DU=PKK(1,5)+PKK(1,6)+D56
17230 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17231 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17232 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17233 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17234 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17235 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17236 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17237 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17238 IF(MSTP(50).LE.0) THEN
17239 WT=FGK135**2+(CCWW*FGK253)**2
17240 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17241 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17244 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17245 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17246 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17247 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17250 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17251 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17252 C...(or H0, or A0).
17253 WT=PKK(1,3)*PKK(2,4)
17254 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17256 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17257 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17258 C...-> f + 2 quarks/leptons.
17259 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17260 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17261 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17262 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17263 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17264 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17265 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17266 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17267 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17268 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17269 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17270 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17271 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17272 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17273 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17274 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17275 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17276 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17278 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17279 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17280 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17281 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17282 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17284 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17286 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17287 WT=16D0*PKK(3,5)*PKK(4,6)
17290 ELSEIF(ISUB.EQ.110) THEN
17291 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17295 ELSEIF(ISUB.EQ.141) THEN
17296 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17297 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17298 C...Couplings of incoming flavour.
17299 KFAI=IABS(MINT(15))
17300 EI=KCHG(KFAI,1)/3D0
17301 AI=SIGN(1D0,EI+0.1D0)
17304 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17305 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17306 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17307 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17308 VPI=PARU(119+2*KFAIC)
17309 API=PARU(120+2*KFAIC)
17310 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17311 VPI=PARJ(178+2*KFAIC)
17312 API=PARJ(179+2*KFAIC)
17314 VPI=PARJ(186+2*KFAIC)
17315 API=PARJ(187+2*KFAIC)
17317 C...Couplings of final flavour.
17319 EF=KCHG(KFAF,1)/3D0
17320 AF=SIGN(1D0,EF+0.1D0)
17323 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17324 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17325 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17326 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17327 VPF=PARU(119+2*KFAFC)
17328 APF=PARU(120+2*KFAFC)
17329 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17330 VPF=PARJ(178+2*KFAFC)
17331 APF=PARJ(179+2*KFAFC)
17333 VPF=PARJ(186+2*KFAFC)
17334 APF=PARJ(187+2*KFAFC)
17336 C...Asymmetry and weight.
17337 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17338 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17339 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17340 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17341 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17342 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17343 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17344 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17345 WTMAX=2D0+ABS(ASYM)
17346 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17347 C...Angular weight for f + fbar -> Z' -> W+ + W-.
17348 RM1=P(NSD(1)+1,5)**2/SH
17349 RM2=P(NSD(1)+2,5)**2/SH
17350 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17351 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17352 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17354 WT=CFLAT+CCOS2*CTHE(1)**2
17355 WTMAX=CFLAT+MAX(0D0,CCOS2)
17356 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17357 & IABS(KFL1(1)).EQ.37)) THEN
17358 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17361 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17362 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17363 RM1=P(NSD(1)+1,5)**2/SH
17364 RM2=P(NSD(1)+2,5)**2/SH
17365 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17366 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17367 WTMAX=1D0+FLAM2/(8D0*RM1)
17368 ELSEIF(MZPWP.EQ.0) THEN
17369 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17370 C...(W:s like if intermediate Z).
17371 D34=P(IREF(IP,IORD),5)**2
17372 D56=P(IREF(IP,3-IORD),5)**2
17373 DT=PKK(1,3)+PKK(1,4)+D34
17374 DU=PKK(1,5)+PKK(1,6)+D56
17375 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17376 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17377 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17378 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17379 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17380 ELSEIF(MZPWP.EQ.1) THEN
17381 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17382 C...(W:s approximately longitudinal, like if intermediate H).
17383 WT=16D0*PKK(3,5)*PKK(4,6)
17386 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17387 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17392 ELSEIF(ISUB.EQ.142) THEN
17393 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17394 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17395 KFAI=IABS(MINT(15))
17397 IF(KFAI.GT.10) KFAIC=2
17398 VI=PARU(129+2*KFAIC)
17399 AI=PARU(130+2*KFAIC)
17402 IF(KFAF.GT.10) KFAFC=2
17403 VF=PARU(129+2*KFAFC)
17404 AF=PARU(130+2*KFAFC)
17405 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
17406 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17407 WTMAX=2D0+ABS(ASYM)
17408 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
17409 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
17410 RM1=P(NSD(1)+1,5)**2/SH
17411 RM2=P(NSD(1)+2,5)**2/SH
17412 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17413 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17414 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17416 WT=CFLAT+CCOS2*CTHE(1)**2
17417 WTMAX=CFLAT+MAX(0D0,CCOS2)
17418 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17419 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
17420 RM1=P(NSD(1)+1,5)**2/SH
17421 RM2=P(NSD(1)+2,5)**2/SH
17422 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17423 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17424 WTMAX=1D0+FLAM2/(8D0*RM1)
17425 ELSEIF(MZPWP.EQ.0) THEN
17426 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
17427 C...(W/Z like if intermediate W).
17428 D34=P(IREF(IP,IORD),5)**2
17429 D56=P(IREF(IP,3-IORD),5)**2
17430 DT=PKK(1,3)+PKK(1,4)+D34
17431 DU=PKK(1,5)+PKK(1,6)+D56
17432 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17433 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
17434 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17435 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
17436 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17437 ELSEIF(MZPWP.EQ.1) THEN
17438 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
17439 C...(W/Z approximately longitudinal, like if intermediate H).
17440 WT=16D0*PKK(3,5)*PKK(4,6)
17443 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
17444 C...t + bbar -> t + W + bbar.
17449 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
17451 C...Isotropic decay of leptoquarks (assumed spin 0).
17455 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
17456 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
17458 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
17459 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
17460 WT=1D0+SIDE*CTHE(1)
17462 ELSEIF(IP.EQ.1) THEN
17464 RM1=P(NSD(1)+1,5)**2/SH
17465 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
17466 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
17468 C...W/Z decay assumed isotropic, since not known.
17473 ELSEIF(ISUB.EQ.149) THEN
17474 C...Isotropic decay of techni-eta.
17478 ELSEIF(ISUB.EQ.191) THEN
17479 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17480 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
17481 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
17484 ELSEIF(IP.EQ.1) THEN
17485 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
17486 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17487 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17488 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17489 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17490 KFAI=IABS(MINT(15))
17491 EI=KCHG(KFAI,1)/3D0
17492 AI=SIGN(1D0,EI+0.1D0)
17496 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
17497 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
17499 EF=KCHG(KFAF,1)/3D0
17500 AF=SIGN(1D0,EF+0.1D0)
17504 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
17505 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
17506 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
17507 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
17508 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
17509 WTMAX=4D0*MAX(ASAME,AFLIP)
17511 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
17516 ELSEIF(ISUB.EQ.192) THEN
17517 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17518 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
17519 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
17522 ELSEIF(IP.EQ.1) THEN
17523 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
17524 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17528 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
17533 ELSEIF(ISUB.EQ.193) THEN
17534 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17535 C...Angular weight for f + fbar -> omega_tc0 ->
17536 C...gamma pi_tc0 or Z0 pi_tc0.
17539 ELSEIF(IP.EQ.1) THEN
17540 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
17541 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17542 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17543 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17544 KFAI=IABS(MINT(15))
17545 EI=KCHG(KFAI,1)/3D0
17546 AI=SIGN(1D0,EI+0.1D0)
17550 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
17551 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
17553 EF=KCHG(KFAF,1)/3D0
17554 AF=SIGN(1D0,EF+0.1D0)
17558 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
17559 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
17560 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
17561 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
17562 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
17563 WTMAX=4D0*MAX(BSAME,BFLIP)
17565 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
17570 ELSEIF(ISUB.EQ.353) THEN
17571 C...Angular weight for Z_R0 -> 2 quarks/leptons.
17572 EI=KCHG(IABS(MINT(15)),1)/3D0
17573 AI=SIGN(1D0,EI+0.1D0)
17575 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
17576 AF=SIGN(1D0,EF+0.1D0)
17578 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
17579 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
17580 WT2=RMF*(VI**2+AI**2)*VF**2
17581 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
17582 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17583 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17584 WTMAX=2D0*(WT1+ABS(WT3))
17586 ELSEIF(ISUB.EQ.354) THEN
17587 C...Angular weight for W_R+/- -> 2 quarks/leptons.
17588 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
17589 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
17590 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17591 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17594 ELSEIF(ISUB.EQ.391) THEN
17595 C...Angular weight for f + fbar -> G* -> f + fbar
17596 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
17597 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
17599 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
17600 C...implemented by M.-C. Lemaire
17601 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
17602 & IABS(KFL1(1)).EQ.22)) THEN
17605 C...Other G* decays not yet implemented angular distributions.
17611 ELSEIF(ISUB.EQ.392) THEN
17612 C...Angular weight for g + g -> G* -> f + fbar
17613 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
17616 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
17617 C...implemented by M.-C. Lemaire
17618 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
17619 & IABS(KFL1(1)).EQ.22)) THEN
17620 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
17622 C...Other G* decays not yet implemented angular distributions.
17628 C...Obtain correct angular distribution by rejection techniques.
17633 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
17635 C...Construct massive four-vectors using angles chosen.
17636 590 DO 690 JT=1,JTMAX
17637 IF(KDCY(JT).EQ.0) GOTO 690
17642 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
17644 IF(KFL3(JT).EQ.0) THEN
17645 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
17646 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
17649 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
17650 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
17655 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17657 C...Fill in position of decay vertex.
17658 DO 630 I=NSD(JT)+1,N0
17667 C...Mark decayed resonances; trace history.
17671 IF(KCQM(JT).NE.0) THEN
17672 C...Do not kill colour flow through coloured resonance!
17676 C...If 3-body or 2-body with junction:
17677 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
17678 C...If 3-body with junction:
17679 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
17682 C...Add documentation lines.
17683 ISUBRG=MAX(1,MIN(500,MINT(1)))
17684 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
17685 IDOC=MINT(83)+MINT(4)
17688 IF(KFL3(JT).NE.0) IHI=IHI+1
17689 DO 650 I=NSD(JT)+1,IHI
17691 I1=MINT(83)+MINT(4)+1
17693 IF(MSTP(128).GE.1) K(I,3)=ID
17694 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17698 K(I1,3)=IREF(IP,JT+3)
17707 C...If 3-body or 2-body with junction:
17708 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
17709 C...If 3-body with junction:
17710 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
17713 C...Do showering of two or three objects.
17715 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
17716 IF(KFL3(JT).EQ.0) THEN
17717 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
17719 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
17722 c...For pT-ordered shower need set up first, especially colour tags.
17723 C...(Need to set up colour tags even if MSTP(71) = 0)
17724 ELSEIF(MINT(35).GE.2) THEN
17726 IF(KFL3(JT).NE.0) NPART=3
17730 PTPART(1)=0.5D0*P(ID,5)
17731 PTPART(2)=PTPART(1)
17732 PTPART(3)=PTPART(1)
17733 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
17734 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
17735 IF(MOTHER.LE.NSD(JT)) THEN
17736 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
17739 MCT(NSD(JT)+1,1)=NCT
17743 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
17744 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
17745 IF(MOTHER.LE.NSD(JT)) THEN
17746 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
17749 MCT(NSD(JT)+1,2)=NCT
17753 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
17754 & KCQ2(JT).EQ.2)) THEN
17755 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
17756 IF(MOTHER.LE.NSD(JT)) THEN
17757 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
17760 MCT(NSD(JT)+2,1)=NCT
17764 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
17765 & KCQ2(JT).EQ.2)) THEN
17766 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
17767 IF(MOTHER.LE.NSD(JT)) THEN
17768 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
17771 MCT(NSD(JT)+2,2)=NCT
17775 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
17776 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
17777 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
17778 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
17780 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
17781 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
17782 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
17783 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
17785 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17788 IF(JT.EQ.1) NAFT1=N
17790 C...Check if decay products moved by shower.
17794 IF(NSHAFT.GT.NSHBEF) THEN
17795 IF(K(NSD1,1).GT.10) THEN
17796 DO 660 I=NSHBEF+1,NSHAFT
17797 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
17800 IF(K(NSD2,1).GT.10) THEN
17801 DO 670 I=NSHBEF+1,NSHAFT
17802 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
17803 & I.NE.NSD1) NSD2=I
17806 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
17807 DO 680 I=NSHBEF+1,NSHAFT
17808 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
17809 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
17814 C...Store decay products for further treatment.
17819 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
17823 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
17824 IREF(NP,7)=K(IREF(IP,JT),2)
17825 IREF(NP,8)=IREF(IP,JT)
17829 C...Fill information for 2 -> 1 -> 2.
17830 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
17831 MINT(7)=MINT(83)+6+2*ISET(ISUB)
17832 MINT(8)=MINT(83)+7+2*ISET(ISUB)
17838 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17839 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
17840 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
17841 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
17842 VINT(47)=SQRT(VINT(48))
17845 C...Possibility of colour rearrangement in W+W- events.
17846 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
17847 IAKF1=IABS(KFL1(1))
17848 IAKF2=IABS(KFL1(2))
17849 IAKF3=IABS(KFL2(1))
17850 IAKF4=IABS(KFL2(2))
17851 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
17852 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
17853 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
17854 IF(MINT(51).NE.0) RETURN
17857 C...Loop back if needed.
17858 710 IF(IP.LT.NP) GOTO 170
17860 C...Boost back to standard frame.
17861 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
17867 C*********************************************************************
17870 C...Initializes treatment of multiple interactions, selects kinematics
17871 C...of hardest interaction if low-pT physics included in run, and
17872 C...generates all non-hardest interactions.
17874 SUBROUTINE PYMULT(MMUL)
17876 C...Double precision and integer declarations.
17877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17878 IMPLICIT INTEGER(I-N)
17879 INTEGER PYK,PYCHGE,PYCOMP
17881 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17883 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17884 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17885 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17886 COMMON/PYINT1/MINT(400),VINT(400)
17887 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17888 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
17889 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
17890 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
17891 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
17892 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
17893 C...Local arrays and saved variables.
17894 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
17895 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
17896 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
17897 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
17899 C...Initialization of multiple interaction treatment.
17901 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
17909 C...Loop over phase space points: xT2 choice in 20 bins.
17912 NMUL(IXT2)=MSTP(83)
17914 DO 110 ITRY=1,MSTP(83)
17915 RSCA=0.05D0*((21-IXT2)-PYR(0))
17916 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
17917 XT2=MAX(0.01D0*VINT(149),XT2)
17920 C...Choose tau and y*. Calculate cos(theta-hat).
17921 IF(PYR(0).LE.COEF(ISUB,1)) THEN
17922 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
17923 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
17925 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
17931 IF(RYST.GT.COEF(ISUB,8)) MYST=2
17932 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
17933 CALL PYKMAP(2,MYST,PYR(0))
17934 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
17936 C...Calculate differential cross-section.
17937 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
17938 CALL PYSIGH(NCHN,SIGS)
17939 SIGM(IXT2)=SIGM(IXT2)+SIGS
17941 SIGSUM=SIGSUM+SIGM(IXT2)
17943 SIGSUM=SIGSUM/(20D0*MSTP(83))
17945 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
17946 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
17947 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
17948 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
17949 PARP(82)=0.9D0*PARP(82)
17950 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
17954 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
17955 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
17957 C...Start iteration to find k factor.
17958 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
17959 P83A=(1D0-PARP(83))**2
17960 P83B=2D0*PARP(83)*(1D0-PARP(83))
17962 CQ2I=1D0/PARP(84)**2
17963 CQ2R=2D0/(1D0+PARP(84)**2)
17971 130 IF(IIT.EQ.0) THEN
17973 ELSEIF(IIT.EQ.1) THEN
17976 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
17979 C...Evaluate overlap integrals. Find where to divide the b range.
17980 IF(MSTP(82).EQ.2) THEN
17981 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
17984 IF(MSTP(82).EQ.3) THEN
17986 ELSEIF(MSTP(82).EQ.4) THEN
17987 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
17989 POWIP=MAX(0.4D0,PARP(83))
17990 RPWIP=2D0/POWIP-1D0
17991 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18001 IF(MSTP(82).EQ.3) THEN
18002 OV=EXP(-B**2)/PARU(2)
18003 ELSEIF(MSTP(82).EQ.4) THEN
18004 OV=(P83A*EXP(-MIN(50D0,B**2))+
18005 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18006 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18008 OV=EXP(-B**POWIP)/PARU(2)
18009 SO=SO+PARU(2)*B*DELTAB*OV
18011 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18012 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18013 SP=SP+PARU(2)*B*DELTAB*PACC
18014 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18015 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18016 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18018 BDIV=B+0.5D0*DELTAB
18020 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18022 YK=PARU(1)*XK*SO/SP
18024 C...Continue iteration until convergence.
18034 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18036 C...Store some results for subsequent use.
18044 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18045 PIK=(VNT146/VNT147)*YKE
18047 C...Find relative weight for low and high impact parameter.
18048 PLOWB=PARU(1)*BDIV**2
18049 IF(MSTP(82).EQ.3) THEN
18050 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18051 ELSEIF(MSTP(82).EQ.4) THEN
18052 S4A=P83A*EXP(-BDIV**2)
18053 S4B=P83B*EXP(-BDIV**2*CQ2R)
18054 S4C=P83C*EXP(-BDIV**2*CQ2I)
18055 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18056 ELSEIF(PARP(83).GE.1.999D0) THEN
18062 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18066 C...Initialize iteration in xT2 for hardest interaction.
18067 ELSEIF(MMUL.EQ.2) THEN
18071 IF(MSTP(82).LE.0) THEN
18072 ELSEIF(MSTP(82).EQ.1) THEN
18074 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18075 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18076 & VINT(317)/(VINT(318)*VINT(320))
18077 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18078 ELSEIF(MSTP(82).EQ.2) THEN
18080 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18081 & VINT(149)*(1D0+VINT(149))
18083 XC2=4D0*CKIN(3)**2/VINT(2)
18084 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18087 C...Select impact parameter for hardest interaction.
18088 IF(MSTP(82).LE.2) RETURN
18089 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18090 C...Treatment in low b region.
18092 B=BDIV*SQRT(PYR(0))
18093 IF(MSTP(82).EQ.3) THEN
18094 OV=EXP(-B**2)/PARU(2)
18095 ELSEIF(MSTP(82).EQ.4) THEN
18096 OV=(P83A*EXP(-MIN(50D0,B**2))+
18097 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18098 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18100 OV=EXP(-B**POWIP)/PARU(2)
18102 VINT(148)=OV/VNT147
18103 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18105 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18106 & VINT(149)*(1D0+VINT(149))
18108 C...Treatment in high b region.
18110 IF(MSTP(82).EQ.3) THEN
18111 B=SQRT(BDIV**2-LOG(PYR(0)))
18112 OV=EXP(-B**2)/PARU(2)
18113 ELSEIF(MSTP(82).EQ.4) THEN
18114 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18115 IF(S4RNDM.LT.S4A) THEN
18116 B=SQRT(BDIV**2-LOG(PYR(0)))
18117 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18118 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18120 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18122 OV=(P83A*EXP(-MIN(50D0,B**2))+
18123 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18124 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18125 ELSEIF(PARP(83).GE.1.999D0) THEN
18126 144 B2RPW=B2RPDV-LOG(PYR(0))
18127 ACCIP=(B2RPW/B2RPDV)**RPWIP
18128 IF(ACCIP.LT.PYR(0)) GOTO 144
18129 OV=EXP(-B2RPW)/PARU(2)
18130 B=B2RPW**(1D0/POWIP)
18132 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18133 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18134 IF(ACCIP.LT.PYR(0)) GOTO 146
18135 OV=EXP(-B2RPW)/PARU(2)
18136 B=B2RPW**(1D0/POWIP)
18138 VINT(148)=OV/VNT147
18139 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18141 IF(PACC.LT.PYR(0)) GOTO 142
18144 ELSEIF(MMUL.EQ.3) THEN
18145 C...Low-pT or multiple interactions (first semihard interaction):
18146 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18147 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18152 IF(MSTP(82).LE.0) THEN
18154 ELSEIF(MSTP(82).EQ.1) THEN
18155 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18156 C...Use with "Sudakov" for low b values when impact parameter dependence.
18157 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18158 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18159 & VINT(149)))).GT.PYR(0)) XT2=1D0
18160 IF(XT2.GE.1D0) THEN
18161 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18162 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18165 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18166 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18169 XT2=MAX(0.01D0*VINT(149),XT2)
18170 C...Use without "Sudakov" for high b values when impact parameter dep.
18172 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18173 & PYR(0)*(1D0-XC2))-VINT(149)
18174 XT2=MAX(0.01D0*VINT(149),XT2)
18178 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18179 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18180 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18181 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18184 VINT(21)=0.01D0*VINT(149)
18187 VINT(25)=0.01D0*VINT(149)
18190 C...Multiple interactions (first semihard interaction).
18191 C...Choose tau and y*. Calculate cos(theta-hat).
18192 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18193 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18194 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18196 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18202 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18203 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18204 CALL PYKMAP(2,MYST,PYR(0))
18205 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18207 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18209 C...Store results of cross-section calculation.
18210 ELSEIF(MMUL.EQ.4) THEN
18216 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18217 IF(ISET(ISUB).EQ.2)
18218 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18219 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18220 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18221 & (XTS+VINT(149))))
18222 IRBIN=INT(1D0+20D0*RBIN)
18223 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18224 NMUL(IRBIN)=NMUL(IRBIN)+1
18225 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18228 C...Choose impact parameter if not already done.
18229 ELSEIF(MMUL.EQ.5) THEN
18234 150 IF(MINT(39).GT.0) THEN
18235 ELSEIF(MSTP(82).EQ.3) THEN
18238 VINT(148)=EXPB2/(PARU(2)*VNT147)
18239 VINT(139)=SQRT(B2)/BAVG
18240 ELSEIF(MSTP(82).EQ.4) THEN
18242 IF(RTYPE.LT.P83A) THEN
18244 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18245 B2=-LOG(PYR(0))/CQ2R
18247 B2=-LOG(PYR(0))/CQ2I
18249 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18250 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18251 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18252 VINT(139)=SQRT(B2)/BAVG
18253 ELSEIF(PARP(83).GE.1.999D0) THEN
18254 POWIP=MAX(2D0,PARP(83))
18255 RPWIP=2D0/POWIP-1D0
18256 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18257 160 IF(PYR(0).LT.PROB1) THEN
18258 B2RPW=PYR(0)**(0.5D0*POWIP)
18261 B2RPW=1D0-LOG(PYR(0))
18264 IF(ACCIP.LT.PYR(0)) GOTO 160
18265 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18266 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18268 POWIP=MAX(0.4D0,PARP(83))
18269 RPWIP=2D0/POWIP-1D0
18270 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18271 170 IF(PYR(0).LT.PROB1) THEN
18272 B2RPW=2D0*RPWIP*PYR(0)
18273 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18275 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18276 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18278 IF(ACCIP.LT .PYR(0)) GOTO 170
18279 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18280 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18283 C...Multiple interactions (variable impact parameter) : reject with
18284 C...probability exp(-overlap*cross-section above pT/normalization).
18285 C...Does not apply to low-b region, where "Sudakov" already included.
18287 IF(MINT(39).NE.1) THEN
18288 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18289 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18290 DO 180 IBIN=IRBIN+1,20
18291 RNCOR=RNCOR+NMUL(IBIN)
18292 SIGCOR=SIGCOR+SIGM(IBIN)
18294 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18295 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18296 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18297 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18299 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18300 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18301 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18302 IF(VINT(150).LT.PYR(0)) GOTO 150
18306 C...Generate additional multiple semihard interactions.
18307 ELSEIF(MMUL.EQ.6) THEN
18320 C...Reconstruct strings in hard scattering.
18322 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18323 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18325 DO 210 I=MINT(84)+1,NMAX
18326 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18327 IF(KCS.EQ.0) GOTO 210
18329 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18330 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18332 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18334 IST=MOD(K(I,J+1),MSTU(5))
18336 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18337 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18339 IF(J.EQ.1.OR.J.EQ.4) THEN
18349 C...Set up starting values for iteration in xT2.
18350 XT2=4D0*VINT(62)/VINT(2)
18351 IF(MSTP(82).LE.1) THEN
18352 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18353 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18354 & VINT(317)/(VINT(318)*VINT(320))
18355 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18357 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18358 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18362 VINT(143)=1D0-VINT(141)
18363 VINT(144)=1D0-VINT(142)
18365 C...Iterate downwards in xT2.
18366 220 IF(MSTP(82).LE.1) THEN
18367 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18368 IF(XT2.LT.VINT(149)) GOTO 270
18370 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18371 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18372 & LOG(PYR(0)))-VINT(149)
18373 IF(XT2.LE.0D0) GOTO 270
18374 XT2=MAX(0.01D0*VINT(149),XT2)
18378 C...Choose tau and y*. Calculate cos(theta-hat).
18379 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18380 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18381 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18383 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18389 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18390 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18391 CALL PYKMAP(2,MYST,PYR(0))
18392 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18394 C...Check that x not used up. Accept or reject kinematical variables.
18395 X1M=SQRT(TAU)*EXP(VINT(22))
18396 X2M=SQRT(TAU)*EXP(-VINT(22))
18397 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
18398 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18399 CALL PYSIGH(NCHN,SIGS)
18400 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
18401 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
18403 C...Reset K, P and V vectors. Select some variables.
18412 PT=0.5D0*VINT(1)*SQRT(XT2)
18416 C...Add first parton to event record.
18419 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
18420 & 1+INT((2D0+PARJ(2))*PYR(0))
18421 P(N+1,1)=PT*COS(PHI)
18422 P(N+1,2)=PT*SIN(PHI)
18423 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
18424 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
18427 C...Add second parton to event record.
18430 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
18433 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
18434 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
18437 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
18438 C....Choose relevant string pieces to place gluons on.
18444 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
18445 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
18446 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
18447 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
18448 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
18456 C....Colour flow adjustments, new string pieces.
18457 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
18458 & MOD(K(IST1,4),MSTU(5))
18459 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
18460 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
18461 K(I,5)=MSTU(5)*IST1
18462 K(I,4)=MSTU(5)*IST2
18463 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
18464 & MOD(K(IST2,5),MSTU(5))
18465 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
18466 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
18469 KSTR(NSTR+1,2)=IST2
18473 C...String drawing and colour flow for gluon loop.
18474 ELSEIF(K(N+1,2).EQ.21) THEN
18475 K(N+1,4)=MSTU(5)*(N+2)
18476 K(N+1,5)=MSTU(5)*(N+2)
18477 K(N+2,4)=MSTU(5)*(N+1)
18478 K(N+2,5)=MSTU(5)*(N+1)
18485 C...String drawing and colour flow for qqbar pair.
18487 K(N+1,4)=MSTU(5)*(N+2)
18488 K(N+2,5)=MSTU(5)*(N+1)
18494 C...Global statistics.
18495 MINT(351)=MINT(351)+1
18496 VINT(351)=VINT(351)+PT
18497 IF (MINT(351).EQ.1) VINT(356)=PT
18499 C...Update remaining energy; iterate.
18501 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
18502 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
18506 MINT(31)=MINT(31)+1
18507 VINT(151)=VINT(151)+VINT(41)
18508 VINT(152)=VINT(152)+VINT(42)
18509 VINT(143)=VINT(143)-VINT(41)
18510 VINT(144)=VINT(144)-VINT(42)
18511 IF(MINT(31).LT.240) GOTO 220
18519 C...Format statements for printout.
18520 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
18521 &'actions for MSTP(82) =',I2,' ******')
18522 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
18523 &D9.2,' mb: rejected')
18524 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
18525 &D9.2,' mb: accepted')
18530 C*********************************************************************
18533 C...Adds on target remnants (one or two from each side) and
18534 C...includes primordial kT for hadron beams.
18536 SUBROUTINE PYREMN(IPU1,IPU2)
18538 C...Double precision and integer declarations.
18539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18540 IMPLICIT INTEGER(I-N)
18541 INTEGER PYK,PYCHGE,PYCOMP
18543 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18544 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18545 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18546 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18547 COMMON/PYINT1/MINT(400),VINT(400)
18548 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
18550 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
18551 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
18553 C...Find event type and remaining energy.
18556 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
18557 VINT(143)=1D0-VINT(141)
18558 VINT(144)=1D0-VINT(142)
18561 C...Define initial partons.
18566 IF(JT.EQ.1) IPU=IPU1
18567 IF(JT.EQ.2) IPU=IPU2
18574 IF(MINT(47).EQ.1) THEN
18578 ELSEIF(ISUB.EQ.95) THEN
18583 C...No primordial kT, or chosen according to truncated Gaussian or
18584 C...exponential, or (for photon) predetermined or power law.
18585 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
18586 IF(MSTP(91).LE.0) THEN
18588 ELSEIF(MSTP(91).EQ.1) THEN
18589 PT=PARP(91)*SQRT(-LOG(PYR(0)))
18593 PT=-PARP(92)*LOG(RPT1*RPT2)
18595 IF(PT.GT.PARP(93)) GOTO 120
18596 ELSEIF(MINT(106+JT).EQ.3) THEN
18597 PTA=SQRT(VINT(282+JT))
18599 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
18600 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
18601 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
18604 PTB=-PARP(99)*LOG(RPT1*RPT2)
18606 IF(PTB.GT.PARP(100)) GOTO 120
18607 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
18608 PT=PT*0.8D0**MINT(57)
18609 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
18610 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
18611 IF(MSTP(93).LE.0) THEN
18613 ELSEIF(MSTP(93).EQ.1) THEN
18614 PT=PARP(99)*SQRT(-LOG(PYR(0)))
18615 ELSEIF(MSTP(93).EQ.2) THEN
18618 PT=-PARP(99)*LOG(RPT1*RPT2)
18619 ELSEIF(MSTP(93).EQ.3) THEN
18622 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
18626 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
18627 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
18629 IF(PT.GT.PARP(100)) GOTO 120
18637 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18640 IF(MINT(47).EQ.1) RETURN
18642 C...Kinematics construction for initial partons.
18645 IF(ISUB.EQ.95) THEN
18649 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
18650 & (P(I1,2)+P(I2,2))**2
18651 SHR=SQRT(MAX(0D0,SHS))
18652 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
18653 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
18654 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
18655 P(I2,4)=SHR-P(I1,4)
18658 C...Transform partons to overall CM-frame.
18659 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
18660 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
18661 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
18662 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
18663 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
18664 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
18665 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
18666 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
18667 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
18668 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
18669 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
18672 C...Optionally fix up x and Q2 definitions for leptoproduction.
18674 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
18675 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
18676 IF(IDISXQ.EQ.1) THEN
18678 C...Find where incoming and outgoing leptons/partons are sitting.
18680 IF(MINT(42).EQ.1) LESD=2
18681 LPIN=MINT(83)+3-LESD
18683 LQIN=MINT(84)+3-LESD
18684 LEOUT=MINT(84)+2+LESD
18685 LQOUT=MINT(84)+5-LESD
18686 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
18687 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
18689 DO 140 I=MINT(84)+5,N
18690 IF(K(I,2).EQ.94) THEN
18697 IF(LESD.EQ.1) LQBG=IPU2
18699 C...Calculate actual and wanted momentum transfer.
18702 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
18703 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
18704 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
18705 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
18706 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
18707 P(N+1,1)=FAC*P(LEOUT,1)
18708 P(N+1,2)=FAC*P(LEOUT,2)
18709 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
18710 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
18711 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
18714 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
18715 QNEW(J)=P(LEIN,J)-P(N+1,J)
18718 C...Boost outgoing electron and daughters.
18719 IF(LSCMS.EQ.0) THEN
18721 P(LEOUT,J)=P(N+1,J)
18725 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
18727 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
18729 DBE(J)=PINV*P(N+2,J)
18733 190 IORIG=K(IORIG,3)
18734 IF(IORIG.GT.LEOUT) GOTO 190
18735 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
18736 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
18740 C...Copy shower initiator and all outgoing partons.
18744 P(NCOP,J)=P(LQBG,J)
18746 DO 240 I=MINT(84)+1,N
18748 IF(K(I,1).GT.10) GOTO 240
18749 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
18753 220 IORIG=K(IORIG,3)
18754 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
18756 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
18769 C...Calculate relative rescaling factors.
18773 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
18776 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
18779 C...Transfer extra three-momentum of current.
18782 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
18784 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
18787 C...Iterate change of initiator momentum to get energy right.
18790 PEEX=-P(N+1,4)-QNEW(4)
18791 PEMV=-P(N+1,3)/P(N+1,4)
18794 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
18796 IF(ABS(PEMV).LT.1D-10) THEN
18798 MINT(57)=MINT(57)+1
18802 P(N+1,3)=P(N+1,3)+PZCH
18803 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)
18805 P(I,3)=P(I,3)+V(I,1)*PZCH
18806 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
18808 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
18810 C...Modify momenta in event record.
18811 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
18812 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
18813 IF(ABS(HBE).GE.1D0) THEN
18815 MINT(57)=MINT(57)+1
18819 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
18828 C...Check minimum invariant mass of remnant system(s).
18829 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
18830 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
18831 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
18832 PMIN(0)=SQRT(PMS(0))
18834 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
18835 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
18837 IF(MINT(44+JT).EQ.1) GOTO 340
18838 MINT(105)=MINT(102+JT)
18839 MINT(109)=MINT(106+JT)
18840 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
18841 IF(MINT(51).NE.0) THEN
18842 MINT(57)=MINT(57)+1
18845 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
18846 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
18847 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
18848 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
18849 & P(MINT(83)+JT+2,2)**2)
18851 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
18852 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
18855 MINT(57)=MINT(57)+1
18859 C...Loop over two remnants; skip if none there.
18863 IF(MINT(44+JT).EQ.1) GOTO 410
18864 IF(JT.EQ.1) IPU=IPU1
18865 IF(JT.EQ.2) IPU=IPU2
18867 C...Store first remnant parton.
18879 P(I,5)=PYMASS(K(I,2))
18881 C...First parton colour connections and kinematics.
18882 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
18885 K(I,4)=MSTU(5)*IPU+IPU
18886 K(I,5)=MSTU(5)*IPU+IPU
18887 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
18888 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
18889 ELSEIF(KCOL.NE.0) THEN
18891 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
18893 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
18895 IF(KFLCH(JT).EQ.0) THEN
18896 P(I,1)=-P(MINT(83)+JT+2,1)
18897 P(I,2)=-P(MINT(83)+JT+2,2)
18898 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18899 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
18903 C...When extra remnant parton or hadron: store extra remnant.
18915 P(I,5)=PYMASS(K(I,2))
18917 C...Find parton colour connections of extra remnant.
18918 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
18921 K(I,4)=MSTU(5)*IPU+IPU
18922 K(I,5)=MSTU(5)*IPU+IPU
18923 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
18924 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
18925 ELSEIF(KCOL.NE.0) THEN
18927 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
18929 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
18932 C...Relative transverse momentum when two remnants.
18935 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
18936 IF(IABS(MINT(10+JT)).LT.20) THEN
18940 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
18941 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
18943 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
18944 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
18945 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
18946 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18948 C...Meson or baryon; photon as meson. For splitup below.
18950 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
18952 C***Relative distribution for electron into two electrons. Temporary!
18953 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
18957 C...Relative distribution of electron energy into electron plus parton.
18958 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
18961 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
18963 C...Relative distribution of energy for particle into two jets.
18964 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
18965 CHIK=PARP(92+2*IMB)
18966 IF(MSTP(92).LE.1) THEN
18967 IF(IMB.EQ.1) CHI(JT)=PYR(0)
18968 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
18969 ELSEIF(MSTP(92).EQ.2) THEN
18970 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
18971 ELSEIF(MSTP(92).EQ.3) THEN
18972 CUT=2D0*0.3D0/VINT(1)
18973 380 CHI(JT)=PYR(0)**2
18974 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
18975 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
18976 ELSEIF(MSTP(92).EQ.4) THEN
18977 CUT=2D0*0.3D0/VINT(1)
18978 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
18979 390 CHIR=CUT*CUTR**PYR(0)
18980 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
18981 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
18983 CUT=2D0*0.3D0/VINT(1)
18984 CUTA=CUT**(1D0-PARP(98))
18985 CUTB=(1D0+CUT)**(1D0-PARP(98))
18986 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
18987 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
18988 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
18991 C...Relative distribution of energy for particle into jet plus particle.
18993 IF(MSTP(94).LE.1) THEN
18994 IF(IMB.EQ.1) CHI(JT)=PYR(0)
18995 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
18996 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
18997 ELSEIF(MSTP(94).EQ.2) THEN
18998 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
18999 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19000 ELSEIF(MSTP(94).EQ.3) THEN
19001 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19004 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19009 C...Construct total transverse mass; reject if too large.
19010 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19011 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19012 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19013 IF(LOOP.LT.100) THEN
19017 MINT(57)=MINT(57)+1
19021 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19022 VINT(158+JT)=CHI(JT)
19024 C...Subdivide longitudinal momentum according to value selected above.
19025 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19026 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19027 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19028 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19029 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19034 C...Check if longitudinal boosts needed - if so pick two systems.
19035 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19036 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19037 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19038 IF(ISN(1).EQ.0) THEN
19041 ELSEIF(ISN(2).EQ.0) THEN
19044 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19047 ELSEIF(VINT(143).GT.0.2D0) THEN
19050 ELSEIF(VINT(144).GT.0.2D0) THEN
19053 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19062 C...E+-pL wanted for system to be modified.
19063 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19067 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19068 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19071 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19072 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19073 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19074 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19078 DO 450 I=MINT(84)+1,NS
19079 IF(K(I,1).GT.10) GOTO 450
19082 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19084 IF(IORIG.GT.LPIN) GOTO 430
19085 IF(INCL.EQ.0) GOTO 450
19087 PSYS(0,J)=PSYS(0,J)+P(I,J)
19090 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19091 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19092 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19095 C...Construct longitudinal boosts.
19099 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19100 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19102 MINT(57)=MINT(57)+1
19105 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19106 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19107 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19108 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19109 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19110 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19111 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19113 C...Perform longitudinal boosts.
19114 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19116 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19117 ELSEIF(IR.EQ.1) THEN
19118 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19119 ELSEIF(IDISXQ.EQ.1) THEN
19123 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19125 IF(IORIG.GT.LPIN) GOTO 460
19126 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19129 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19131 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19133 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19134 ELSEIF(IL.EQ.2) THEN
19135 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19136 ELSEIF(IDISXQ.EQ.1) THEN
19140 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19142 IF(IORIG.GT.LPIN) GOTO 480
19143 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19146 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19149 C...Final check that energy-momentum conservation worked.
19152 DO 500 I=MINT(84)+1,N
19153 IF(K(I,1).GT.10) GOTO 500
19157 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19158 IF(PDEV.GT.1D-4*VINT(1)) THEN
19160 MINT(57)=MINT(57)+1
19164 C...Calculate rotation and boost from overall CM frame to
19165 C...hadronic CM frame in leptoproduction.
19167 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19170 IF(MINT(42).EQ.1) LESD=2
19171 LPIN=MINT(83)+3-LESD
19173 C...Sum upp momenta of everything not lepton or photon to define boost.
19178 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19179 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19180 IF(K(I,2).EQ.22) GOTO 530
19182 PSUM(J)=PSUM(J)+P(I,J)
19185 VINT(223)=-PSUM(1)/PSUM(4)
19186 VINT(224)=-PSUM(2)/PSUM(4)
19187 VINT(225)=-PSUM(3)/PSUM(4)
19189 C...Boost incoming hadron to hadronic CM frame to determine rotations.
19195 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19196 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19197 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19199 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19201 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19208 C*********************************************************************
19211 C...Initializes treatment of new multiple interactions scenario,
19212 C...selects kinematics of hardest interaction if low-pT physics
19213 C...included in run, and generates all non-hardest interactions.
19215 SUBROUTINE PYMIGN(MMUL)
19217 C...Double precision and integer declarations.
19218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19219 IMPLICIT INTEGER(I-N)
19220 INTEGER PYK,PYCHGE,PYCOMP
19222 DOUBLE PRECISION PYALPS
19224 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19227 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19228 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19230 COMMON/PYINT1/MINT(400),VINT(400)
19231 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19232 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19233 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19234 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19235 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19236 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19237 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19238 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19239 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19240 C...Local arrays and saved variables.
19241 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19242 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19243 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19244 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19245 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19247 C...Initialization of multiple interaction treatment.
19249 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19257 C...Loop over phase space points: xT2 choice in 20 bins.
19260 NMUL(IXT2)=MSTP(83)
19262 DO 110 ITRY=1,MSTP(83)
19263 RSCA=0.05D0*((21-IXT2)-PYR(0))
19264 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19265 XT2=MAX(0.01D0*VINT(149),XT2)
19268 C...Choose tau and y*. Calculate cos(theta-hat).
19269 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19270 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19271 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19273 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19279 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19280 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19281 CALL PYKMAP(2,MYST,PYR(0))
19282 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19284 C...Calculate differential cross-section.
19285 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19286 CALL PYSIGH(NCHN,SIGS)
19287 SIGM(IXT2)=SIGM(IXT2)+SIGS
19289 SIGSUM=SIGSUM+SIGM(IXT2)
19291 SIGSUM=SIGSUM/(20D0*MSTP(83))
19293 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19294 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19295 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19296 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19297 PARP(82)=0.9D0*PARP(82)
19298 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19302 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19303 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19305 C...Start iteration to find k factor.
19306 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19307 P83A=(1D0-PARP(83))**2
19308 P83B=2D0*PARP(83)*(1D0-PARP(83))
19310 CQ2I=1D0/PARP(84)**2
19311 CQ2R=2D0/(1D0+PARP(84)**2)
19319 130 IF(IIT.EQ.0) THEN
19321 ELSEIF(IIT.EQ.1) THEN
19324 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19327 C...Evaluate overlap integrals. Find where to divide the b range.
19328 IF(MSTP(82).EQ.2) THEN
19329 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19332 IF(MSTP(82).EQ.3) THEN
19334 ELSEIF(MSTP(82).EQ.4) THEN
19335 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19337 POWIP=MAX(0.4D0,PARP(83))
19338 RPWIP=2D0/POWIP-1D0
19339 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19349 IF(MSTP(82).EQ.3) THEN
19350 OV=EXP(-B**2)/PARU(2)
19351 ELSEIF(MSTP(82).EQ.4) THEN
19352 OV=(P83A*EXP(-MIN(50D0,B**2))+
19353 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19354 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19356 OV=EXP(-B**POWIP)/PARU(2)
19357 SO=SO+PARU(2)*B*DELTAB*OV
19359 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19360 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19361 SP=SP+PARU(2)*B*DELTAB*PACC
19362 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19363 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19364 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19366 BDIV=B+0.5D0*DELTAB
19368 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19370 YK=PARU(1)*XK*SO/SP
19372 C...Continue iteration until convergence.
19382 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19384 C...Store some results for subsequent use.
19392 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19393 PIK=(VNT146/VNT147)*YKE
19395 C...Find relative weight for low and high impact parameter..
19396 PLOWB=PARU(1)*BDIV**2
19397 IF(MSTP(82).EQ.3) THEN
19398 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19399 ELSEIF(MSTP(82).EQ.4) THEN
19400 S4A=P83A*EXP(-BDIV**2)
19401 S4B=P83B*EXP(-BDIV**2*CQ2R)
19402 S4C=P83C*EXP(-BDIV**2*CQ2I)
19403 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19404 ELSEIF(PARP(83).GE.1.999D0) THEN
19410 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19414 C...Initialize iteration in xT2 for hardest interaction.
19415 ELSEIF(MMUL.EQ.2) THEN
19419 IF(MSTP(82).LE.0) THEN
19420 ELSEIF(MSTP(82).EQ.1) THEN
19422 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19423 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19424 & VINT(317)/(VINT(318)*VINT(320))
19425 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19426 ELSEIF(MSTP(82).EQ.2) THEN
19428 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19429 & VINT(149)*(1D0+VINT(149))
19431 XC2=4D0*CKIN(3)**2/VINT(2)
19432 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19435 C...Select impact parameter for hardest interaction.
19436 IF(MSTP(82).LE.2) RETURN
19437 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19438 C...Treatment in low b region.
19440 B=BDIV*SQRT(PYR(0))
19441 IF(MSTP(82).EQ.3) THEN
19442 OV=EXP(-B**2)/PARU(2)
19443 ELSEIF(MSTP(82).EQ.4) THEN
19444 OV=(P83A*EXP(-MIN(50D0,B**2))+
19445 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19446 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19448 OV=EXP(-B**POWIP)/PARU(2)
19450 VINT(148)=OV/VNT147
19451 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19453 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19454 & VINT(149)*(1D0+VINT(149))
19456 C...Treatment in high b region.
19458 IF(MSTP(82).EQ.3) THEN
19459 B=SQRT(BDIV**2-LOG(PYR(0)))
19460 OV=EXP(-B**2)/PARU(2)
19461 ELSEIF(MSTP(82).EQ.4) THEN
19462 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19463 IF(S4RNDM.LT.S4A) THEN
19464 B=SQRT(BDIV**2-LOG(PYR(0)))
19465 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19466 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19468 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19470 OV=(P83A*EXP(-MIN(50D0,B**2))+
19471 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19472 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19473 ELSEIF(PARP(83).GE.1.999D0) THEN
19474 144 B2RPW=B2RPDV-LOG(PYR(0))
19475 ACCIP=(B2RPW/B2RPDV)**RPWIP
19476 IF(ACCIP.LT.PYR(0)) GOTO 144
19477 OV=EXP(-B2RPW)/PARU(2)
19478 B=B2RPW**(1D0/POWIP)
19480 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19481 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19482 IF(ACCIP.LT.PYR(0)) GOTO 146
19483 OV=EXP(-B2RPW)/PARU(2)
19484 B=B2RPW**(1D0/POWIP)
19486 VINT(148)=OV/VNT147
19487 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19489 IF(PACC.LT.PYR(0)) GOTO 142
19492 ELSEIF(MMUL.EQ.3) THEN
19493 C...Low-pT or multiple interactions (first semihard interaction):
19494 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19495 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19500 IF(MSTP(82).LE.0) THEN
19502 ELSEIF(MSTP(82).EQ.1) THEN
19503 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19504 C...Use with "Sudakov" for low b values when impact parameter dependence.
19505 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19506 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19507 & VINT(149)))).GT.PYR(0)) XT2=1D0
19508 IF(XT2.GE.1D0) THEN
19509 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19510 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19513 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19514 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19517 XT2=MAX(0.01D0*VINT(149),XT2)
19518 C...Use without "Sudakov" for high b values when impact parameter dep.
19520 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19521 & PYR(0)*(1D0-XC2))-VINT(149)
19522 XT2=MAX(0.01D0*VINT(149),XT2)
19526 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19527 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19528 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19529 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19532 VINT(21)=1D-12*VINT(149)
19535 VINT(25)=1D-12*VINT(149)
19538 C...Multiple interactions (first semihard interaction).
19539 C...Choose tau and y*. Calculate cos(theta-hat).
19540 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19541 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19542 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19544 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19550 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19551 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19552 CALL PYKMAP(2,MYST,PYR(0))
19553 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19555 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19557 C...Store results of cross-section calculation.
19558 ELSEIF(MMUL.EQ.4) THEN
19564 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19565 IF(ISET(ISUB).EQ.2)
19566 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19567 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19568 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19569 & (XTS+VINT(149))))
19570 IRBIN=INT(1D0+20D0*RBIN)
19571 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19572 NMUL(IRBIN)=NMUL(IRBIN)+1
19573 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19576 C...Choose impact parameter if not already done.
19577 ELSEIF(MMUL.EQ.5) THEN
19582 150 IF(MINT(39).GT.0) THEN
19583 ELSEIF(MSTP(82).EQ.3) THEN
19586 VINT(148)=EXPB2/(PARU(2)*VNT147)
19587 VINT(139)=SQRT(B2)/BAVG
19588 ELSEIF(MSTP(82).EQ.4) THEN
19590 IF(RTYPE.LT.P83A) THEN
19592 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19593 B2=-LOG(PYR(0))/CQ2R
19595 B2=-LOG(PYR(0))/CQ2I
19597 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19598 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19599 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19600 VINT(139)=SQRT(B2)/BAVG
19601 ELSEIF(PARP(83).GE.1.999D0) THEN
19602 POWIP=MAX(2D0,PARP(83))
19603 RPWIP=2D0/POWIP-1D0
19604 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19605 160 IF(PYR(0).LT.PROB1) THEN
19606 B2RPW=PYR(0)**(0.5D0*POWIP)
19609 B2RPW=1D0-LOG(PYR(0))
19612 IF(ACCIP.LT.PYR(0)) GOTO 160
19613 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19614 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19616 POWIP=MAX(0.4D0,PARP(83))
19617 RPWIP=2D0/POWIP-1D0
19618 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19619 170 IF(PYR(0).LT.PROB1) THEN
19620 B2RPW=2D0*RPWIP*PYR(0)
19621 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19623 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19624 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19626 IF(ACCIP.LT .PYR(0)) GOTO 170
19627 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19628 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19631 C...Multiple interactions (variable impact parameter) : reject with
19632 C...probability exp(-overlap*cross-section above pT/normalization).
19633 C...Does not apply to low-b region, where "Sudakov" already included.
19635 IF(MINT(39).NE.1) THEN
19636 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19637 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19638 DO 180 IBIN=IRBIN+1,20
19639 RNCOR=RNCOR+NMUL(IBIN)
19640 SIGCOR=SIGCOR+SIGM(IBIN)
19642 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19643 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19644 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19645 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19647 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19648 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19649 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19650 IF(VINT(150).LT.PYR(0)) GOTO 150
19654 C...Generate additional multiple semihard interactions.
19655 ELSEIF(MMUL.EQ.6) THEN
19657 C...Save data for hardest initeraction, to be restored.
19674 C...Store data on hardest interaction.
19681 C...Change process to generate; sum of x values so far.
19684 VINT(143)=1D0-VINT(141)
19685 VINT(144)=1D0-VINT(142)
19689 C...Initialize factors for PDF reshaping.
19693 KFSBM=ISIGN(1,KFBEAM)
19695 C...Zero flavour content of incoming beam particle.
19699 C...Flavour content of baryon.
19700 IF(KFABM.GT.1000) THEN
19701 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
19702 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
19703 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
19704 C...Flavour content of pi+-, K+-.
19705 ELSEIF(KFABM.EQ.211) THEN
19706 KFIVAL(JS,1)=KFSBM*2
19707 KFIVAL(JS,2)=-KFSBM
19708 ELSEIF(KFABM.EQ.321) THEN
19709 KFIVAL(JS,1)=-KFSBM*3
19710 KFIVAL(JS,2)=KFSBM*2
19711 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
19714 C...Zero initial valence and companion content.
19719 C...Initiate listing of all incoming partons from two sides.
19721 DO 210 I=MINT(84)+1,N
19722 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
19728 C...Decide whether quarks in hard scattering were valence or sea.
19729 IFL=K(IMI(JS,1,1),2)
19730 IF (IABS(IFL).GT.6) GOTO 230
19732 C...Get PDFs at X and Q2 of the parton shower initiator for the
19733 C...hard scattering.
19735 IF(MSTP(61).GE.1) THEN
19740 C...Note: XPSVC = x*pdf.
19742 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
19746 C...Decide (Extra factor x cancels in the division).
19747 RVCS=PYR(0)*(SEA+VAL)
19749 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
19750 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
19752 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
19753 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
19754 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
19755 IF(KFIVAL(JS,1).EQ.0) THEN
19756 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
19757 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
19758 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
19759 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
19761 IF(IVNOW.EQ.0) GOTO 220
19764 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
19765 IF(KFIVAL(JS,1).EQ.0) THEN
19766 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
19769 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
19771 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
19772 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
19776 C...If sea, add opposite sign companion parton. Store X and I.
19778 NVC(JS,-IFL)=NVC(JS,-IFL)+1
19779 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
19780 C...Set pointer to companion
19781 IMI(JS,1,2)=-NVC(JS,-IFL)
19785 C...Update counter number of multiple interactions.
19789 C...Set up starting values for iteration in xT2.
19790 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
19791 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
19792 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
19793 & ISUBSV.NE.96)) THEN
19794 XT2=(1D0-VINT(141))*(1D0-VINT(142))
19797 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
19798 IF(ISET(ISUBSV).EQ.2)
19799 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19800 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
19802 IF(MSTP(82).LE.1) THEN
19803 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19804 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19805 & VINT(317)/(VINT(318)*VINT(320))
19806 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19808 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19809 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19814 C...Iterate downwards in xT2.
19815 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
19818 ELSEIF(MSTP(82).LE.1) THEN
19819 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19820 IF(XT2.LT.VINT(149)) GOTO 440
19822 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
19823 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19824 & LOG(PYR(0)))-VINT(149)
19825 IF(XT2.LE.0D0) GOTO 440
19826 XT2=MAX(0.01D0*VINT(149),XT2)
19830 C...Choose tau and y*. Calculate cos(theta-hat).
19831 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19832 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19833 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19835 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19838 C...New: require shat > 1.
19839 IF(TAU*VINT(2).LT.1D0) GOTO 240
19843 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19844 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19845 CALL PYKMAP(2,MYST,PYR(0))
19846 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19848 C...Check that x not used up. Accept or reject kinematical variables.
19849 X1M=SQRT(TAU)*EXP(VINT(22))
19850 X2M=SQRT(TAU)*EXP(-VINT(22))
19851 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
19852 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19853 CALL PYSIGH(NCHN,SIGS)
19854 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19855 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
19856 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
19858 C...Reset K, P and V vectors.
19866 PT=0.5D0*VINT(1)*SQRT(XT2)
19868 C...Choose flavour of reacting partons (and subprocess).
19873 ICONMI=ISIG(ICHN,3)
19874 RSIGS=RSIGS-SIGH(ICHN)
19875 IF(RSIGS.LE.0D0) GOTO 280
19878 C...Reassign to appropriate process codes.
19879 280 ISUBMI=ICONMI/10
19880 ICONMI=MOD(ICONMI,10)
19882 C...Choose new quark flavour for annihilation graphs
19883 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
19885 CALL PYWIDT(21,SH,WDTP,WDTE)
19886 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
19887 DO 300 I=1,MDCY(21,3)
19888 KFLF=KFDP(I+MDCY(21,2)-1,1)
19889 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
19890 IF(RKFL.LE.0D0) GOTO 310
19892 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
19893 IF(KFLF.GE.4) GOTO 290
19894 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
19897 ELSEIF(ISUBMI.EQ.53) THEN
19903 C...Final state flavours and colour flow: default values
19910 IF(ISUBMI.EQ.11) THEN
19911 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
19913 IF(KFL1*KFL2.LT.0) KCC=KCC+2
19915 ELSEIF(ISUBMI.EQ.12) THEN
19916 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
19917 KFL3=ISIGN(KFLF,KFL1)
19921 ELSEIF(ISUBMI.EQ.13) THEN
19922 C...f + fbar -> g + g; th arbitrary
19927 ELSEIF(ISUBMI.EQ.28) THEN
19928 C...f + g -> f + g; th = (p(f)-p(f))**2
19929 IF(KFL1.EQ.21) JS=2
19931 IF(KFL1.EQ.21) KCC=KCC+2
19932 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
19933 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
19935 ELSEIF(ISUBMI.EQ.53) THEN
19936 C...g + g -> f + fbar; th arbitrary
19937 KCS=(-1)**INT(1.5D0+PYR(0))
19938 KFL3=ISIGN(KFLF,KCS)
19942 ELSEIF(ISUBMI.EQ.68) THEN
19943 C...g + g -> g + g; th arbitrary
19945 KCS=(-1)**INT(1.5D0+PYR(0))
19948 C...Store flavours of scattering.
19956 C...Set flavours and mothers of scattering partons.
19965 K(N+1,3)=MINT(83)+1
19966 K(N+2,3)=MINT(83)+2
19970 C...Store colour connection indices.
19973 IF(KCS.EQ.-1) JC=3-J
19974 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
19975 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
19976 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
19977 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
19980 C...Store incoming and outgoing partons in their CM-frame.
19981 SHR=SQRT(TAU)*VINT(1)
19984 P(N+2,3)=-0.5D0*SHR
19986 P(N+3,5)=PYMASS(K(N+3,2))
19987 P(N+4,5)=PYMASS(K(N+4,2))
19988 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
19989 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
19990 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
19991 P(N+4,4)=SHR-P(N+3,4)
19994 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
19996 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
19998 C...Set up default values before showers.
19999 MINT(31)=MINT(31)+1
20008 C...Showering of initial state partons (optional).
20009 C...Note: no showering of final state partons here; it comes later.
20010 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20017 KSAV(I,J)=K(N-4+I,J)
20018 PSAV(I,J)=P(N-4+I,J)
20021 CALL PYSSPA(IPU1,IPU2)
20023 C...If shower failed then restore to situation before shower.
20024 IF(MINT(51).GE.1) THEN
20028 K(N-4+I,J)=KSAV(I,J)
20029 P(N-4+I,J)=PSAV(I,J)
20039 C...Keep track of loose colour ends and information on scattering.
20040 370 IMI(1,MINT(31),1)=IPU1
20041 IMI(2,MINT(31),1)=IPU2
20042 IMI(1,MINT(31),2)=0
20043 IMI(2,MINT(31),2)=0
20044 XMI(1,MINT(31))=VINT(141)
20045 XMI(2,MINT(31))=VINT(142)
20046 PT2MI(MINT(31))=VINT(54)
20049 C...Decide whether quarks in last scattering were valence, companion or
20053 KFSBM=ISIGN(1,MINT(10+JS))
20054 IFL=K(IMI(JS,MINT(31),1),2)
20055 IMI(JS,MINT(31),2)=0
20056 IF (IABS(IFL).GT.6) GOTO 430
20058 C...Get PDFs at X and Q2 of the parton shower initiator for the
20059 C...last scattering. At this point VINT(143:144) do not yet
20060 C...include the scattered x values VINT(141:142).
20061 X=VINT(140+JS)/VINT(142+JS)
20062 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20067 C...Note: XPSVC = x*pdf.
20069 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20073 DO 380 IVC=1,NVC(JS,IFL)
20074 CMP=CMP+XPSVC(IFL,IVC)
20077 C...Decide (Extra factor x cancels in the dvision).
20078 RVCS=PYR(0)*(SEA+VAL+CMP)
20080 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20081 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20083 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20084 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20085 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20086 IF(KFIVAL(JS,1).EQ.0) THEN
20087 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20088 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20089 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20090 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20092 DO 400 I1=1,NMI(JS)
20093 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20097 IF(IVNOW.EQ.0) GOTO 390
20099 IMI(JS,MINT(31),2)=0
20100 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20101 IF(KFIVAL(JS,1).EQ.0) THEN
20102 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20105 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20107 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20108 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20112 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20113 C...If sea, add opposite sign companion parton. Store X and I.
20114 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20115 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20116 C...Set pointer to companion
20117 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20119 C...If companion, decide which one.
20123 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20124 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20125 C...Find original sea (anti-)quark:
20127 DO 420 I1=1,NMI(JS)
20128 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20129 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20130 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20131 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20134 C...Change X to what associated companion had, so that the correct
20135 C...amount of momentum can be subtracted from the companion sum below.
20136 X=XASSOC(JS,IFL,ISEL)
20137 C...Mark companion read.
20138 XASSOC(JS,IFL,ISEL)=0D0
20142 C...Global statistics.
20143 MINT(351)=MINT(351)+1
20144 VINT(351)=VINT(351)+PT
20145 IF (MINT(351).EQ.1) VINT(356)=PT
20147 C...Update remaining energy and other counters.
20148 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20149 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20155 VINT(151)=VINT(151)+VINT(41)
20156 VINT(152)=VINT(152)+VINT(42)
20157 VINT(143)=VINT(143)-VINT(141)
20158 VINT(144)=VINT(144)-VINT(142)
20160 C...Iterate, with more interactions allowed.
20161 IF(MINT(31).LT.240) GOTO 240
20164 C...Restore saved quantities for hardest interaction.
20180 C...Format statements for printout.
20181 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20182 &'actions for MSTP(82) =',I2,' ******')
20183 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20184 &D9.2,' mb: rejected')
20185 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20186 &D9.2,' mb: accepted')
20191 C*********************************************************************
20194 C...Finds left-behind remnant flavour content and hooks up
20195 C...the colour flow between the hard scattering and remnants
20199 C...Double precision and integer declarations.
20200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20201 IMPLICIT INTEGER(I-N)
20202 INTEGER PYK,PYCHGE,PYCOMP
20203 C...The event record
20204 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20208 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20209 COMMON/PYINT1/MINT(400),VINT(400)
20210 C...The common block of dangling ends
20211 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20212 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20213 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20214 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20215 C...Local variables
20216 PARAMETER (NERSIZ=4000)
20217 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20219 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20220 SAVE /PYCBLS/,/PYCTAG/
20221 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20222 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20225 FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1)
20227 C...Set up error checkers
20230 C...Initialize colour arrays: MCO (Original) and MCT (New)
20231 DO 110 I=MINT(84)+1,NERSIZ
20236 C...Also zero colour tracing information, if existed.
20238 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20239 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20243 C...Initialize colour tag collapse arrays:
20244 C...JCCO (Original) and JCCN (New).
20245 DO 130 MG=MINT(84)+1,NERSIZ
20252 C...Zero gluon insertion array
20259 C...Compute hard scattering system rapidities
20260 IF (MSTP(89).EQ.1) THEN
20262 IF (IM.LE.MINT(31)) THEN
20263 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20265 C...Set (unsigned) rapidity = 100 for beam remnant systems.
20271 C...Treat each side separately
20274 C...Initialize side.
20277 KFS=ISIGN(1,MINT(10+JS))
20279 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20280 IF(KFIVAL(JS,1).EQ.0) THEN
20281 IF(MINT(10+JS).EQ.111) THEN
20282 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20283 KFIVAL(JS,2)=-KFIVAL(JS,1)
20284 ELSEIF(MINT(10+JS).EQ.22) THEN
20287 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20288 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20289 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20290 KFIVAL(JS,2)=-KFIVAL(JS,1)
20291 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20292 IF(PYR(0).GT.0.5D0) THEN
20302 C...Initialize beam remnant sea and valence content flavour by flavour.
20306 C...Count up original number of JFA valence quarks and antiquarks.
20311 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20312 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20314 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20315 C...Subtract kicked out valence and determine sea from flavour cons.
20316 DO 180 IM=1,NMI(JS)
20317 IFL = K(IMI(JS,IM,1),2)
20320 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20321 C...Subtract K.O. valence quark from remainder.
20323 JV=NVSUM(JS)-NVALQ-NVALQB
20324 IV(JS,JV)=IMI(JS,IM,1)
20325 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20326 C...Subtract K.O. valence antiquark from remainder.
20328 JV=NVSUM(JS)-NVALQ-NVALQB
20329 IV(JS,JV)=IMI(JS,IM,1)
20330 ELSEIF (IFA.EQ.JFA) THEN
20331 C...Outside sea without companion: add opposite sea flavour inside.
20332 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20335 C...Check if space left in PYJETS for additional BR flavours
20336 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20337 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20338 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20339 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20343 C...Add required val+sea content to beam remnant.
20344 IF (NFLSUM.GT.0) THEN
20346 C...Insert beam remnant quark as p.t. symbolic parton in ER.
20354 K(N,2)=ISIGN(JFA,NSEA)
20355 IF (IA.LE.NVALQ) K(N,2)=JFA
20356 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20358 C...Also update NMI, IMI, and IV arrays.
20360 IMI(JS,NMI(JS),1)=N
20361 IMI(JS,NMI(JS),2)=-1
20362 IF (IA.LE.NVALQ+NVALQB) THEN
20363 IMI(JS,NMI(JS),2)=0
20365 IV(JS,JV)=IMI(JS,NMI(JS),1)
20373 IF (IM.LE.NMI(JS)) THEN
20374 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20376 C...Add fictitious parent gluons for companion pairs.
20377 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20378 C...Randomly assign companions to sea quarks which have none.
20379 IF (IMI(JS,IM,2).LT.0) THEN
20381 230 IMC=MOD(IMC,NMI(JS))+1
20382 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20383 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20384 IMI(JS, IM,2) = IMI(JS,IMC,1)
20385 IMI(JS,IMC,2) = IMI(JS, IM,1)
20387 C...Add fictitious parent gluon
20397 C...Set gluon (anti-)colour daughter pointers
20398 K(N,4)=IMI(JS, IM,1)
20399 K(N,5)=IMI(JS, IM,2)
20400 C...Set quark (anti-)colour parent pointers
20401 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
20402 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
20403 C...Add gluon to IMI
20405 IMI(JS,NMI(JS),1)=N
20406 IMI(JS,NMI(JS),2)=0
20411 C...If incoming (anti-)baryon, insert inside (anti-)junction.
20412 C...Set up initial v-v-j-v configuration. Otherwise set up
20413 C...mesonic v-vbar configuration
20414 IF (IABS(MINT(10+JS)).GT.1000) THEN
20415 C...Determine junction type (1: B=1 2: B=-1)
20416 ITJUNC(JS) = (3-KFS)/2
20417 C...Insert junction.
20424 C...Set special junction codes:
20427 C...Set parent to side.
20429 K(N,4)=ITJUNC(JS)*MSTU(5)
20431 C...Connect valence quarks to junction.
20434 C...Set (anti)colour mother = junction.
20436 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
20438 C...Keep track of partons adjacent to junction:
20439 JST(JS,JV)=IV(JS,JV)
20442 C...Mesons: set up initial q-qbar topology
20444 IF (K(IV(JS,1),2).GT.0) THEN
20455 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
20456 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
20457 C...Special for mesons. Insert gluon if BR empty.
20458 IF (NBRTOT(JS).EQ.0) THEN
20472 C...Add gluon to IMI
20474 IMI(JS,NMI(JS),1)=N
20475 IMI(JS,NMI(JS),2)=0
20480 C...Count up number of valence quarks outside BR.
20482 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
20483 & MOUT(JS)=MOUT(JS)+1
20488 C...Now both sides have been prepared in an initial vvjv (baryonic) or
20489 C...v(g)vbar (mesonic) configuration.
20491 C...Create colour line tags starting from initiators.
20493 DO 320 IM=1,MINT(31)
20494 C...Consider each side in turn.
20499 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
20501 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
20504 CALL PYCTTR(I1,KCS,I2)
20505 IF(MINT(51).NE.0) RETURN
20512 C...Create colour tags for beam remnant partons.
20513 DO 330 IM=MINT(31)+1,NMI(JS)
20515 IF (K(IP,2).NE.21) THEN
20516 JC=(3-ISIGN(1,K(IP,2)))/2
20517 IF (MCT(IP,JC).EQ.0) THEN
20526 C...Fictituous gluons just inherit from their quark daughters.
20530 C...Real beam remnant gluons get their own colours
20541 C...Create colour tags for colour lines which are detached from the
20545 DO 350 I=MINT(84)+1,N
20547 C...Look for coloured string endpoint, or (later) leftover gluon.
20548 IF (K(I,1).NE.3) GOTO 350
20550 IF(KC.EQ.0) GOTO 350
20552 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
20554 C...Pick up loose string end with no previous tag.
20556 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
20557 IF(MCT(I,KCS-3).NE.0) GOTO 350
20559 CALL PYCTTR(I,KCS,I)
20560 IF(MINT(51).NE.0) RETURN
20565 C...Store original colour tags
20566 DO 370 I=MINT(84)+1,N
20571 C...Iteratively add gluons to already existing string pieces, enforcing
20572 C...various possible orderings, and rejecting insertions that would give
20573 C...rise to singlet gluons.
20574 C...<kappa tau> normalization.
20579 C...Set up simplified kinematics.
20580 C...Boost hard interaction systems.
20582 DO 380 IM=1,MINT(31)
20583 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
20584 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
20586 C...Assign preliminary beam remnant momenta.
20587 DO 390 I=MINT(53)+1,N
20591 IF (K(I,2).NE.88) THEN
20592 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
20594 IF (JS.EQ.2) P(I,3)=-P(I,3)
20596 C...Junctions are wildcards for the present.
20602 C...Reset colour processing information.
20603 400 DO 410 I=MINT(84)+1,N
20604 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20605 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20610 C...If meson, without gluon in BR, collapse q-qbar colour tags:
20611 IF (ITJUNC(JS).EQ.0) THEN
20612 JC1=MCT(JST(JS,1),1)
20613 JC2=MCT(JST(JS,2),2)
20615 JCCO(NCC,1)=MAX(JC1,JC2)
20616 JCCO(NCC,2)=MIN(JC1,JC2)
20617 C...Collapse colour tags in event record
20618 DO 420 I=MINT(84)+1,N
20619 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
20620 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
20626 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
20627 IF (NG(JS).GT.0) THEN
20630 C...Start at random gluon (optimizes speed for random attachments)
20632 IMGL=PYR(0)*NMI(JS)+1
20633 450 IMGL=MOD(IMGL,NMI(JS))+1
20635 C...Only loop through NMI once (with upper limit to save time)
20636 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
20637 IGL = IMI(JS,IMGL,1)
20638 C...If not gluon or if already connected, try next.
20639 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
20640 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
20641 C...Now loop through all possible insertions of this gluon.
20643 IMP1=PYR(0)*NMI(JS)+1
20644 460 IMP1=MOD(IMP1,NMI(JS))+1
20646 IF (IMP1.EQ.IMGL) GOTO 460
20647 C...Only loop through NMI once (with upper limit to save time).
20648 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
20649 IP1 = IMI(JS,IMP1,1)
20650 C...Try both colour mother and colour anti-mother.
20651 C...Randomly select which one to try first.
20654 470 MANTI=MOD(MANTI+1,2)
20656 IF (NANTI.LE.2) THEN
20657 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
20658 C...Reject if no appropriate mother (or if mother is fictitious
20660 IF (IP2.LE.0) GOTO 470
20661 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
20662 C...Also reject if this link has already been tried.
20663 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
20664 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
20665 C...Set flag to indicate that this link has now been tried for this
20666 C...gluon. IP2 may be junction, which has several mothers.
20667 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
20668 IF (K(IP2,2).NE.88) THEN
20669 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
20672 C...JCG1: Original colour tag of gluon on IP1 side
20673 C...JCG2: Original colour tag of gluon on IP2 side
20674 C...JCP1: Original colour tag of IP1 on gluon side
20675 C...JCP2: Original colour tag of IP2 on gluon side.
20676 JCG1=MCO(IGL,2-MANTI)
20677 JCG2=MCO(IGL,1+MANTI)
20678 JCP1=MCO(IP1,1+MANTI)
20679 JCP2=MCO(IP2,2-MANTI)
20681 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
20682 C...Reject gluon attachments that give rise to singlet gluons.
20683 IF (MACCPT.EQ.0) GOTO 470
20686 JCG1=MCT(IGL,2-MANTI)
20687 JCG2=MCT(IGL,1+MANTI)
20688 JCP1=MCT(IP1,1+MANTI)
20689 JCP2=MCT(IP2,2-MANTI)
20691 C...Select whether to accept this insertion
20692 IF (MSTP(89).EQ.0) THEN
20693 C...Random insertions: no measure.
20695 C...For random ordering, we want to suppress beam remnant breakups
20696 C...already at this point.
20697 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
20698 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
20703 ELSEIF (MSTP(89).EQ.1) THEN
20704 C...Rapidity ordering:
20705 C...YGL = Rapidity of gluon.
20707 C...If fictitious gluon
20708 IF (YGL.EQ.100D0) THEN
20710 IDA1=MOD(K(IGL,4),MSTU(5))
20711 IDA2=MOD(K(IGL,5),MSTU(5))
20712 DO 480 IMT=1,NMI(JS)
20713 C...Select (arbitrarily) the most central daughter.
20714 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
20716 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
20720 C...YP1 = Rapidity IP1
20722 C...If fictitious gluon
20723 IF (YP1.EQ.100D0) THEN
20725 IDA1=MOD(K(IP1,4),MSTU(5))
20726 IDA2=MOD(K(IP1,5),MSTU(5))
20727 DO 490 IMT=1,NMI(JS)
20728 C...Select (arbitrarily) the most central daughter.
20729 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
20731 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
20735 C...YP2 = Rapidity of mother system
20736 IF (K(IP2,2).NE.88) THEN
20737 DO 500 IMT=1,NMI(JS)
20738 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
20740 C...If fictitious gluon
20741 IF (YP2.EQ.100D0) THEN
20743 IDA1=MOD(K(IP2,4),MSTU(5))
20744 IDA2=MOD(K(IP2,5),MSTU(5))
20745 DO 510 IMT=1,NMI(JS)
20746 C...Select (arbitrarily) the most central daughter.
20747 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
20749 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
20753 C...Assign (arbitrarily) 100D0 to junction also
20757 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
20758 ELSEIF (MSTP(89).EQ.2) THEN
20759 C...Lambda ordering:
20760 C...Compute lambda measure for this insertion.
20765 C...If IP2 is junction, not caught below.
20766 IF (JCP2.EQ.0) THEN
20767 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
20768 C...Anti-junction is colour endpoint et vv., always on JCG2.
20771 DO 530 I=MINT(84)+1,N
20772 IF (K(I,1).LT.10) THEN
20773 C...The new string pieces
20774 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
20775 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
20776 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
20777 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
20780 C...Also identify junctions as string endpoints.
20781 DO 540 I=MINT(84)+1,N
20782 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
20783 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
20784 C...Find partons adjacent to junctions.
20785 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
20786 & .EQ.0) ISTR(2) = ICMO
20787 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
20788 & .EQ.0) ISTR(1) = IAMO
20789 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
20790 & .EQ.0) ISTR(4) = ICMO
20791 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
20792 & .EQ.0) ISTR(3) = IAMO
20794 C...The old string piece
20795 ISTR(5)=ISTR(1+2*MANTI)
20796 ISTR(6)=ISTR(4-2*MANTI)
20797 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
20798 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
20801 C...Allow some breadth to speed things up.
20802 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
20804 ELSEIF (RL.GT.RLOPT) THEN
20810 C...INSR(NOPT,1)=Gluon colour mother
20811 C...INSR(NOPT,2)=Gluon
20812 C...INSR(NOPT,3)=Gluon anticolour mother
20813 IF (NOPT.GT.1000) GOTO 470
20814 INSR(NOPT,1+2*MANTI)=IP2
20816 INSR(NOPT,3-2*MANTI)=IP1
20817 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
20819 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
20821 C...Reset link test information.
20822 DO 550 I=MINT(84)+1,N
20823 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20824 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20826 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
20828 C...Now we have a list of best gluon insertions, none of which cause
20829 C...singlets to arise. If list is empty, try again a few times. Note:
20830 C...this should never happen if we have a meson with a gluon inserted
20831 C...in the beam remnant, since that breaks up the colour line.
20832 IF (NOPT.EQ.0) THEN
20833 C...Abandon BR-g-BR suppression for retries. This is not serious, it
20834 C...just means we happened to start with trying a bad sequence.
20836 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
20837 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
20840 IF (ITJUNC(JS).NE.0) THEN
20844 C...Reset valence quark parent pointers
20845 DO 560 I=MINT(53)+1,N
20846 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
20849 C...Set (anti)colour mother = junction.
20851 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
20855 C...Same for mesons. JST unchanged, so needn't be restored.
20858 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
20859 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
20861 C...Also reset gluon parent pointers.
20863 DO 580 IM=1,NMI(JS)
20865 IF (K(I,2).EQ.21) THEN
20866 K(I,4)=MOD(K(I,4),MSTU(5))
20867 K(I,5)=MOD(K(I,5),MSTU(5))
20872 C...Reset colour tags
20873 DO 600 I=MINT(84)+1,N
20879 IF(NERRPR.LT.5) THEN
20882 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
20883 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
20885 C...Kill event and start another.
20890 C...Select between insertions, suppressing insertions wholly in the BR.
20892 610 IIN=MOD(IIN,NOPT)+1
20893 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
20894 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
20897 C...Now we know which gluon to insert where. Colour tags in JCCO and
20898 C...colour connection information should be updated, NG(JS) should be
20899 C...counted down, and a new loop performed if there are still gluons
20900 C...left on any side.
20904 C...JCG : Original gluon colour tag
20905 C...JCAG: Original gluon anticolour tag.
20906 C...JCM : Original anticolour tag of gluon colour mother
20907 C...JACM: Original colour tag of gluon anticolour mother
20913 CALL PYMIHG(JACM,JACG,JCM,JCG)
20914 IF (MACCPT.EQ.0) THEN
20915 IF(NERRPR.LT.5) THEN
20918 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
20919 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
20921 C...Kill event and start another.
20925 C...If everything went fine, store new JCCN in JCCO.
20928 JCCO(ICC,1)=JCCN(ICC,1)
20929 JCCO(ICC,2)=JCCN(ICC,2)
20933 C...One gluon attached is counted as equivalent to one end outside.
20935 C...Set IGL colour mother = ICM.
20936 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
20937 C...Set ICM anticolour mother = IGL colour.
20938 IF (K(ICM,2).NE.88) THEN
20939 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
20941 C...If ICM is junction, just update JST array for now.
20943 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
20946 C...Set IGL anticolour mother = IACM.
20947 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
20948 C...Set IACM anticolour mother = IGL anticolour.
20949 IF (K(IACM,2).NE.88) THEN
20950 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
20952 C...If IACM is junction, just update JST array for now.
20954 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
20957 C...Count down # unconnected gluons.
20960 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
20963 C...Collapse fictitious gluons.
20964 DO 670 IGL=MINT(53)+1,N
20965 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
20966 & K(IGL,1).EQ.14) THEN
20967 ICM=K(IGL,4)/MSTU(5)
20968 IAM=K(IGL,5)/MSTU(5)
20969 ICD=MOD(K(IGL,4),MSTU(5))
20970 IAD=MOD(K(IGL,5),MSTU(5))
20971 C...Set gluon daughters pointing to gluon mothers
20972 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
20973 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
20974 C...Set gluon mothers pointing to gluon daughters.
20975 IF (K(ICM,2).NE.88) THEN
20976 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
20978 C...Special case: mother=junction. Just update JST array for now.
20980 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
20983 IF (K(IAM,2).NE.88) THEN
20984 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
20987 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
20993 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
20996 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
20997 IF (IM.GT.MINT(31)) THEN
20999 DO 690 IMR=IM,NMI(JS)
21000 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21001 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21006 C...Finally, connect junction.
21007 IF (ITJUNC(JS).NE.0) THEN
21008 DO 700 I=MINT(53)+1,N
21009 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21011 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21016 C...Find jq with no glue inbetween inside beam remnant.
21017 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21020 C...Set IDQ = -I if q non-valence and = +I if q valence.
21021 IDQ(NBRJQ)=-JST(JS,MSJ)
21023 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21024 IDQ(NBRJQ)=JST(JS,MSJ)
21031 IF (MSJ.EQ.3) I45=4
21032 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21035 C...Check if diquark can be formed.
21036 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21038 C...If there is less than 2 valence quarks connected to junction
21039 C...and MSTP(88)>1, use random non-valence quarks to fill up.
21040 IF (NBRVQ.LE.1) THEN
21042 730 JFLIP=NBRJQ*PYR(0)+1
21043 IF (IDQ(JFLIP).LT.0) THEN
21044 IDQ(JFLIP)=-IDQ(JFLIP)
21047 IF (NDIQ.LE.1) GOTO 730
21049 C...Place selected quarks first in IDQ, ordered in flavour.
21051 IF (IDQ(JDQ).LE.0) THEN
21055 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21062 C...Choose diquark spin.
21063 IF (NBRVQ.EQ.2) THEN
21064 C...If the selected quarks are both valence, we may use SU(6) rules
21065 C...to figure out which spin the diquark has, by a subdivision of the
21066 C...original beam hadron into the selected diquark system plus a kicked
21067 C...out quark, IKO.
21071 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21075 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21077 C...If one or more of the selected quarks are not valence, we cannot use
21078 C...SU(6) subdivisions of the original beam hadron. Instead, with the
21079 C...flavours of the diquark already selected, we assume for now
21080 C...50:50 spin-1:spin-0 (where spin-0 possible).
21081 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21083 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21084 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21085 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21088 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21089 C...Note: third quark can per definition not also be valence,
21090 C...therefore we can only do this if we are allowed to use sea quarks.
21091 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21094 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21095 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21097 ELSEIF(NTRY.GT.100) THEN
21098 C...If no baryon can be found, give up and form diquark.
21102 C...Replace junction by baryon.
21105 K(IJU,3)=MINT(83)+JS
21108 P(IJU,5)=PYMASS(KFBAR)
21110 C...Prepare removal of participating quarks from ER.
21111 K(JST(JS,MSJ),1)=-1
21115 C...If collapse to baryon not possible or not allowed, replace junction
21116 C...by diquark. This way, collapsed gluons that were pointing at the
21117 C...junction will now point (correctly) at diquark.
21121 K(IJU,3)=MINT(83)+JS
21126 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21128 K(IJU,5-MANTI)=IP*MSTU(5)
21129 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21131 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21133 C...Prepare removal of participating quarks from ER.
21139 C...Update so ER pointers to collapsed quarks
21140 C...now go to collapsed object.
21141 DO 820 I=MINT(84)+1,N
21142 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21143 & .K(I,1).GT.0) THEN
21145 IMO=K(I,ISID)/MSTU(5)
21146 IDA=MOD(K(I,ISID),MSTU(5))
21148 IF (K(IMO,1).EQ.-1) IMO=IJU
21151 IF (K(IDA,1).EQ.-1) IDA=IJU
21153 K(I,ISID)=IDA+MSTU(5)*IMO
21160 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21161 C...(this only happens for baryons, where we want to force the gluon
21162 C...to sit next to the junction. Mesons handled above.)
21163 IF (NBRTOT(JS).EQ.0) THEN
21173 K(IGL,3)=MINT(83)+JS
21174 IF (ITJUNC(JS).NE.0) THEN
21175 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21176 JLEG=PYR(0)*NVSUM(JS)+1
21179 JCT=MCT(I1,ITJUNC(JS))
21180 MCT(IGL,3-ITJUNC(JS))=JCT
21182 MCT(IGL,ITJUNC(JS))=NCT
21185 C...Meson. Should not happen.
21186 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21187 IF(NERRPR.LT.5) THEN
21188 WRITE(MSTU(11),*) 'This should not have been possible!'
21195 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21196 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21197 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21198 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21199 IF (K(I2,2).NE.88) THEN
21200 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21202 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21203 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21204 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21205 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21207 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21213 C...Remove collapsed quarks and junctions from ER and update IMI.
21216 C...Also update beam remnant part of IMI.
21219 DO 850 I=MINT(53)+1,N
21220 IF (K(I,1).LE.0) GOTO 850
21221 C...Restore BR quark/diquark/baryon pointers in IMI.
21222 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21225 IMI(JS,NMI(JS),1)=I
21226 IMI(JS,NMI(JS),2)=0
21230 C...Restore companion information from collapsed gluons.
21231 DO 870 I=MINT(53)+1,N
21232 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21234 JCD=MOD(K(I,4),MSTU(5))
21235 JAD=MOD(K(I,5),MSTU(5))
21236 DO 860 IM=1,NMI(JS)
21237 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21238 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21240 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21241 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21245 C...Renumber colour lines (since some have disappeared)
21253 IF (MFOUND.EQ.0) JCD=JCD+1
21254 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21257 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21261 IF (I.LE.N) GOTO 890
21262 IF (JCT.LT.NCT) GOTO 880
21265 C...Reset hard interaction subsystems to their CM frames.
21266 IF (IBOOST.EQ.1) THEN
21267 DO 900 IM=1,MINT(31)
21268 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21269 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21271 C...Zero beam remnant longitudinal momenta and energies
21272 DO 910 I=MINT(53)+1,N
21278 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21279 C...Kill event and start another.
21287 C*********************************************************************
21290 C...Adapted from PYPREP.
21291 C...Assigns LHA1 colour tags to coloured partons based on
21292 C...K(I,4) and K(I,5) colour connection record.
21293 C...KCS negative signifies that a previous tracing should be continued.
21294 C...(in case the tag to be continued is empty, the routine exits)
21295 C...Starts at I and ends at I or IEND.
21296 C...Special considerations for systems with junctions.
21298 SUBROUTINE PYCTTR(I,KCS,IEND)
21299 C...Double precision and integer declarations.
21300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21301 INTEGER PYK,PYCHGE,PYCOMP
21303 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21306 COMMON/PYINT1/MINT(400),VINT(400)
21307 C...The common block of colour tags.
21308 COMMON/PYCTAG/NCT,MCT(4000,2)
21309 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21313 C...Skip if KCS not existing for this parton
21314 KQ=KCHG(PYCOMP(K(I,2)),2)
21315 IF (KQ.EQ.0) GOTO 120
21316 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21321 C...Set colour tag of first parton.
21327 IF (NCS.EQ.0) GOTO 120
21333 IF(NSTP.GT.4*N) THEN
21334 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21338 C...Finished if reached final-state triplet.
21339 IF(K(IA,1).EQ.3) THEN
21340 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21343 C...Also finished if reached junction.
21344 IF(K(IA,1).EQ.42) THEN
21348 C...GOTO next parton in colour space.
21350 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21351 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21353 IA=MOD(K(IB,KCS),MSTU(5))
21354 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21357 C...If KCS mother traced or KCS mother nonexistent, switch colour.
21358 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21359 & MSTU(5)).EQ.0) THEN
21363 C...Assign new colour tag on other side of old parton.
21366 C...Goto (new) KCS mother, set mother traced tag
21367 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21368 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21371 IF(IA.LE.0.OR.IA.GT.N) THEN
21372 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21373 IF(NERRPR.LT.5) THEN
21374 write(*,*) 'began at ',I
21375 write(*,*) 'ended going from', IB, ' to', IA
21382 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21383 & MSTU(5)).EQ.IB) THEN
21384 IF(MREV.EQ.1) KCS=9-KCS
21385 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21386 C...Set KSC mother traced tag for IA
21387 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21389 IF(MREV.EQ.0) KCS=9-KCS
21390 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
21391 C...Set KCS daughter traced tag for IA
21392 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
21394 C...Assign new colour tag
21396 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
21401 *********************************************************************
21404 C...Collapse JCP1 and connecting tags to JCG1.
21405 C...Collapse JCP2 and connecting tags to JCG2.
21407 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
21408 C...Double precision and integer declarations.
21409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21410 IMPLICIT INTEGER(I-N)
21411 INTEGER PYK,PYCHGE,PYCOMP
21412 C...The event record
21413 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21415 COMMON/PYINT1/MINT(400),VINT(400)
21416 SAVE /PYJETS/,/PYINT1/
21417 C...Local variables
21418 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
21419 COMMON /PYCTAG/NCT,MCT(4000,2)
21420 SAVE /PYCBLS/,/PYCTAG/
21422 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
21423 C...in temporary tag collapse array JCCN. Only break up one connection.
21427 JCCN(ICC,1)=JCCO(ICC,1)
21428 JCCN(ICC,2)=JCCO(ICC,2)
21429 C...If there was a mother, it was previously connected to JCP1.
21430 C...Should be changed to JCP2.
21431 IF (MCLPS.EQ.0) THEN
21432 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
21434 JCCN(ICC,1)=MAX(JCG2,JCP2)
21435 JCCN(ICC,2)=MIN(JCG2,JCP2)
21440 C...Also collapse colours on JCP1 side of JCG1
21441 IF (JCP1.NE.0) THEN
21442 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
21443 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
21445 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
21446 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
21449 C...Initialize event record colour tag array MCT array to MCO.
21450 DO 110 I=MINT(84)+1,N
21456 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
21457 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
21458 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
21459 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
21461 C...Skip if junction.
21462 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
21463 C...Define starting point in tag space.
21464 C...JCA = previous tag
21465 C...JCO = present tag
21467 IF (MOD(IS,2).EQ.1) THEN
21471 ELSEIF (MOD(IS,2).EQ.0) THEN
21477 120 ITRACE=ITRACE+1
21478 IF (ITRACE.GT.1000) THEN
21479 C...NB: Proper error message should be defined here.
21481 & ,'(PYMIHG:) Inf loop when collapsing colours.')
21482 MINT(57)=MINT(57)+1
21486 C...Collapse all JCN tags to JCALL
21487 DO 130 I=MINT(84)+1,N
21488 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
21489 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
21491 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
21492 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
21499 C...If possible, step from JCO to new tag JCN not equal to JCA.
21501 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
21503 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
21506 C...Iterate if new colour was arrived at, but don't go in circles.
21507 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
21508 C...Change all JCN tags in MCO to JCALL in MCT.
21509 DO 150 I=MINT(84)+1,N
21510 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
21511 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
21512 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
21513 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
21518 DO 200 JCL=NCT,1,-1
21523 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
21525 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
21528 C...Overpaint all JCN with JCL
21529 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
21530 DO 190 I=MINT(84)+1,N
21531 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
21532 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
21533 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
21534 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
21545 C*********************************************************************
21548 C...Picks primordial kT and shares longitudinal momentum among
21553 C...Double precision and integer declarations.
21554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21555 IMPLICIT INTEGER(I-N)
21556 INTEGER PYK,PYCHGE,PYCOMP
21557 C...The event record
21558 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21562 COMMON/PYINT1/MINT(400),VINT(400)
21563 C...The common block of colour tags.
21564 COMMON/PYCTAG/NCT,MCT(4000,2)
21565 C...The common block of dangling ends
21566 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21567 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21568 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21569 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
21570 C...Local variables
21571 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
21572 C...W(I,J)| J=0 | 1 | 2 |
21573 C... I=0 | Wrem**2 | W+ | W- |
21574 C... 1 | W1**2 | W1+ | W1- |
21575 C... 2 | W2**2 | W2+ | W2- |
21577 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)
21578 C...Tentative parametrization of <kT> as a function of Q.
21579 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
21580 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
21581 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
21582 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
21583 C...Lambda kinematic function.
21584 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
21586 C...Beginning and end of beam remnant partons
21590 C...Loopback point if kinematic choices gives impossible configuration.
21594 C...Assign kT values on each side separately.
21597 C...First zero all kT on this side. Skip if no kT to generate.
21598 DO 110 IM=1,NMI(JS)
21599 P(IMI(JS,IM,1),1)=0D0
21600 P(IMI(JS,IM,1),2)=0D0
21602 IF(MSTP(91).LE.0) GOTO 180
21604 C...Now assign kT to each (non-collapsed) parton in IMI.
21605 DO 170 IM=1,NMI(JS)
21607 C...Select kT according to truncated gaussian or 1/kt6 tails.
21608 C...For first interaction, either use rms width = PARP(91) or fitted.
21611 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
21616 C...For subsequent interactions and BR partons use fragmentation width.
21621 IF(NTRY.LE.100) THEN
21622 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
21626 ELSEIF (MSTP(91).EQ.2) THEN
21627 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
21628 & 'available, using MSTP(91)=1.')
21629 CALL PYGIVE('MSTP(91)=1')
21631 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
21632 C...Use distribution with kt**6 tails, rms width = PARP(91).
21633 EPS=SQRT(3D0/2D0)*SIGMA
21634 C...Generate PTX and PTY separately, each propto 1/KT**6
21636 C...Decide which interval to try
21637 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
21638 IF (PYR(0).LT.P12) THEN
21639 C...Use flat approx with accept/reject up to EPS.
21641 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
21642 IF (PYR(0).GT.WT) GOTO 112
21644 C...Above EPS, use 1/kt**6 approx with accept/reject.
21645 PT=EPS/(PYR(0)**(1D0/5D0))
21646 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
21647 IF (PYR(0).GT.WT) GOTO 112
21650 IF (PYR(0).GT.0.5D0) MSIGN=-1
21651 IF (IXY.EQ.1) PTX=MSIGN*PT
21652 IF (IXY.EQ.2) PTY=MSIGN*PT
21654 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
21655 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
21656 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
21658 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
21659 PT=SQRT(PTX**2+PTY**2)
21661 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
21662 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
21665 PT=SQRT(PTX**2+PTY**2)
21671 C...Compensation kicks, with varying degree of local anticorrelations.
21673 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
21674 PTCX=-PTX/(NMI(JS)-1)
21675 PTCY=-PTY/(NMI(JS)-1)
21676 IF(ISUB.EQ.95) THEN
21677 PTCX=-PTX/(NMI(JS)-2)
21678 PTCY=-PTY/(NMI(JS)-2)
21680 DO 120 IMC=1,NMI(JS)
21681 IF (IMC.EQ.IM) GOTO 120
21682 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
21683 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
21684 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
21686 ELSEIF (MCORR.GE.1) THEN
21689 C...Count up # of neighbours on either side
21691 130 IMO=K(IMO,MSID)/MSTU(5)
21692 IF (IMO.EQ.0) GOTO 140
21693 NNXT(MSID-3)=NNXT(MSID-3)+1
21694 C...Stop at quarks and junctions
21695 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
21697 C...How should compensation be shared when unequal numbers on the
21698 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
21699 NSUM=NNXT(1)+NNXT(2)
21702 C...Total momentum to be compensated on this side
21703 IF (NNXT(MSID-3).EQ.0) GOTO 160
21704 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
21705 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
21706 C...RS: compensation supression factor as we go out from parton I.
21707 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
21708 C...since (for now) MSTP(90) provides enough variability.
21710 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
21713 IMO=K(IMO,MSID)/MSTU(5)
21714 IF (IMO.EQ.0) GOTO 160
21716 IF (K(IMO,2).NE.88) THEN
21717 P(IMO,1)=P(IMO,1)+FAC*PTCX
21718 P(IMO,2)=P(IMO,2)+FAC*PTCY
21719 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
21720 C...If we reach junction, divide out the kT that would have been
21721 C...assigned to the junction on each of its other legs.
21723 L1=MOD(K(IMO,4),MSTU(5))
21724 L2=K(IMO,5)/MSTU(5)
21725 L3=MOD(K(IMO,5),MSTU(5))
21726 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
21727 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
21728 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
21729 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
21730 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
21731 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
21732 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
21733 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
21739 C...End assignment of kT values to initiators and remnants.
21742 C...Check kinematics constraints for non-BR partons.
21743 DO 190 IM=1,MINT(31)
21744 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
21745 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
21746 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
21747 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
21748 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
21749 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
21750 IF(NTRY.GE.100) THEN
21751 C...Kill this event and start another.
21753 & '(PYMIRM:) No consistent (x,kT) sets found')
21761 C...Calculate W+ and W- available for combined remnant system.
21764 DO 200 IM=1,MINT(31)
21765 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
21766 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
21767 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
21768 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
21769 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
21771 C...Also store Wrem**2 = W+ * W-
21772 W(0,0)=W(0,1)*W(0,2)
21774 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
21775 IF(NTRY.GE.100) THEN
21776 C...Kill this event and start another.
21778 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
21785 C...Assign unscaled x values to partons/hadrons in each of the
21786 C...beam remnants and calculate unscaled W+ and W- from them.
21792 DO 270 IM=MINT(31)+1,NMI(JS)
21798 C...Skip collapsed gluons and junctions. Reset.
21799 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
21800 IF (KFA.EQ.88) GOTO 270
21807 C...If gluon then only beam remnant, so takes all.
21810 C...If valence quark then use parametrized valence distribution.
21811 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
21813 C...If companion quark then derive from companion x.
21814 ELSEIF(KFA.LE.6) THEN
21816 C...If valence diquark then use two parametrized valence distributions.
21817 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
21819 IVALQ(1)=ISIGN(KFA/1000,KF)
21820 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
21821 C...If valence+sea diquark then combine valence + companion choices.
21822 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
21823 & ICOMP.LT.MSTU(5)) THEN
21824 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
21825 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
21827 IVALQ(1)=ISIGN(KFA/1000,KF)
21830 C...Extra code: workaround for diquark made out of two sea
21831 C...quarks, but where not (yet) ICOMP > MSTU(5).
21832 DO 220 IM1=1,MINT(31)
21833 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
21834 ICOMQ(2)=IMI(JS,IM1,1)
21838 C...If sea diquark then sum of two derived from companion x.
21839 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
21840 ICOMQ(1)=MOD(ICOMP,MSTU(5))
21841 ICOMQ(2)=ICOMP/MSTU(5)
21842 C...If meson or baryon then use fragmentation function.
21843 C...Somewhat arbitrary split into old and new flavour, but OK normally.
21845 KFL3=MOD(KFA/10,10)
21846 IF(MOD(KFA/1000,10).EQ.0) THEN
21847 KFL1=MOD(KFA/100,10)
21849 KFL1=MOD(KFA,10000)-10*KFL3-1
21850 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
21851 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
21853 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
21854 CALL PYZDIS(KFL1,KFL3,PR,X)
21858 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
21859 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
21860 C...In other baryons combine u and d from proton appropriately.
21861 IF(IVALQ(IQ).NE.0) THEN
21863 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
21864 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
21865 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
21867 IF(KFIVAL(JS,3).EQ.0) THEN
21869 C...Baryon with three identical quarks: mix u and d forms.
21870 ELSEIF(NVAL.EQ.3) THEN
21871 MDU=INT(PYR(0)+5D0/3D0)
21872 C...Baryon, one of two identical quarks: u form.
21873 ELSEIF(NVAL.EQ.2) THEN
21875 C...Baryon with two identical quarks, but not the one picked: d form.
21876 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
21877 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
21879 C...Baryon with three nonidentical quarks: mix u and d forms.
21881 MDU=INT(PYR(0)+5D0/3D0)
21884 IF(MDU.EQ.1) XPOW=3.5D0
21885 IF(MDU.EQ.2) XPOW=2D0
21887 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
21891 C...Calculation of x of companion quark.
21892 IF(ICOMQ(IQ).NE.0) THEN
21894 DO 240 IM1=1,MINT(31)
21895 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
21897 NPOW=MAX(0,MIN(4,MSTP(87)))
21898 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
21899 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
21900 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
21901 IF(CORR.LT.PYR(0)) GOTO 250
21906 C...Optionally enchance x of composite systems (e.g. diquarks)
21907 IF (KFA.GT.100) X=PARP(79)*X
21909 C...Store x. Also calculate light cone energies of each system.
21911 W(JS,JS)=W(JS,JS)+X
21912 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
21914 W(JS,JS)=W(JS,JS)*W(0,JS)
21915 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
21916 W(JS,0)=W(JS,1)*W(JS,2)
21919 C...Check W1 W2 < Wrem (can be done before rescaling, since W
21920 C...insensitive to global rescalings of the BR x values).
21921 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
21924 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
21926 ELSEIF (NTRYX.GT.100) THEN
21927 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
21928 MINT(57)=MINT(57)+1
21933 C...Compute x rescaling factors
21934 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
21935 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
21936 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
21938 IF (R1.LT.0.OR.R2.LT.0) THEN
21939 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
21940 MINT(57)=MINT(57)+1
21944 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
21950 C...Rescale BR x values.
21951 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
21952 XMI(1,IM)=XMI(1,IM)*R1
21953 XMI(2,IM)=XMI(2,IM)*R2
21956 C...Now we have a consistent set of x and kT values.
21957 C...First set up the initiators and their daughters correctly.
21958 DO 300 IM=1,MINT(31)
21961 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
21962 & (P(I1,2)+P(I2,2))**2
21963 PT12=P(I1,1)**2+P(I1,2)**2
21964 PT22=P(I2,1)**2+P(I2,2)**2
21966 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
21968 C...Energies (masses should be zero at this stage)
21969 P(I1,4)=SQRT(PT12+P(I1,3)**2)
21970 P(I2,4)=SQRT(PT22+P(I2,3)**2)
21972 C...Transverse 12 system initiator velocity:
21973 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
21974 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
21975 C...Boost to overall initiator system rest frame
21976 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
21977 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
21978 C...Compute phi,theta coordinates of I1 and rotate z axis.
21979 PHI=PYANGL(P(I1,1),P(I1,2))
21980 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
21981 CALL PYROBO(I1,I1,0D0,-PHI,0D0,0D0,0D0)
21982 CALL PYROBO(I2,I2,0D0,-PHI,0D0,0D0,0D0)
21983 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
21984 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
21986 C...Now boost initiators + daughters back to LAB system
21987 C...(also update documentation lines for MI = 1.)
21988 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21989 IMIN=IMISEP(IM-1)+1
21990 IF (IM.EQ.1) IMIN=MINT(83)+5
21992 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
21993 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
21998 C...For the beam remnant partons/hadrons, we only need to set pz and E.
22000 DO 310 IM=MINT(31)+1,NMI(JS)
22002 C...Skip collapsed gluons and junctions.
22003 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22004 IF (KFA.EQ.88) GOTO 310
22005 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22006 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22007 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22008 IF (JS.EQ.2) P(I,3)=-P(I,3)
22013 C...Documentation lines
22019 K(IN,3)=MINT(83)+JS
22026 MCT(IN,1)=MCT(IO,1)
22027 MCT(IN,2)=MCT(IO,2)
22030 C...Final state colour reconnections.
22031 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22033 C...Number of colour tags for which a recoupling will be tried.
22035 C...Number of recouplings to try
22043 IF (IITER.LE.PARP(78)*NTOT) THEN
22044 C...Select two colour tags at random
22045 C...NB: jj strings do not have colour tags assigned to them,
22046 C...thus they are as yet not affected by anything done here.
22048 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22053 C...Find final state partons with this (anti)colour
22054 DO 370 I=MINT(84)+1,N
22055 IF (K(I,1).EQ.3) THEN
22056 IF (MCT(I,1).EQ.JCT) IJ1=I
22057 IF (MCT(I,2).EQ.JCT) IJ2=I
22058 IF (MCT(I,1).EQ.KCT) IK1=I
22059 IF (MCT(I,2).EQ.KCT) IK2=I
22062 C...Only consider recouplings not involving junctions for now.
22063 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22065 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22066 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22067 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22070 C...Count up number of reconnections
22071 MINT(34)=MINT(34)+1
22073 IF (MINT(34).LE.1000) THEN
22076 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22080 IF (NRECP.LT.MINT(34)) GOTO 350
22082 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22088 C*********************************************************************
22091 C...Performs colour annealing.
22092 C...MSTP(95) : CR Type
22093 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22094 C... = 2 : Type I(no gg loops); hadron-hadron only
22095 C... = 3 : Type I(no gg loops); all beams
22096 C... = 4 : Type II(gg loops) ; hadron-hadron only
22097 C... = 5 : Type II(gg loops) ; all beams
22098 C... = 6 : Type S ; hadron-hadron only
22099 C... = 7 : Type S ; all beams
22100 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22101 C...Type S is driven by starting only from free triplets, not octets.
22102 C...A string piece remains unchanged with probability
22103 C... PKEEP = (1-PARP(78))**N
22104 C...This scaling corresponds to each string piece having to go through
22105 C...N other ones, each with probability PARP(78) for reconnection, where
22106 C...N is here chosen simply as the number of multiple interactions,
22107 C...for a rough scaling with the general level of activity.
22109 SUBROUTINE PYFSCR(IP)
22110 C...Double precision and integer declarations.
22111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22112 INTEGER PYK,PYCHGE,PYCOMP
22114 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22115 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22118 COMMON/PYINT1/MINT(400),VINT(400)
22119 C...The common block of colour tags.
22120 COMMON/PYCTAG/NCT,MCT(4000,2)
22121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22123 C...MCN: Temporary storage of new colour tags
22124 DOUBLE PRECISION MCN(4000,2)
22126 C...Function to give four-product.
22127 FOUR(I,J)=P(I,4)*P(J,4)
22128 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22130 C...Check valid range of MSTP(95), local copy
22131 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22132 MSTP95=MOD(MSTP(95),10)
22133 C...Set whether CR allowed inside resonance systems or not
22134 C...(not implemented yet)
22136 C IF (MSTP(95).GE.10) MRESCR=0
22138 C...Check whether colour tags already defined
22139 IF (MINT(33).EQ.0) THEN
22140 C...Erase any existing colour tags for this event
22145 C...Create colour tags for this event
22147 IF (K(I,1).EQ.3) THEN
22150 IF (MCT(I,KCSIN-3).EQ.0) THEN
22151 CALL PYCTTR(I,KCSIN,I)
22156 C...Instruct PYPREP to use colour tags
22160 C...For MSTP(95) even, only apply to hadron-hadron
22161 IF (MOD(MSTP(95),2).EQ.0) THEN
22164 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22167 C...Initialize new tag array (but do not delete old yet)
22169 DO 130 I=MAX(1,IP),N
22174 C...For each final-state dipole, check whether string should be
22179 DO 140 I=MAX(1,IP),N
22180 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22181 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22183 IF (IC.NE.0.AND.IA.NE.0) THEN
22184 C...Chiefly consider large strings.
22185 PKEEP=(1D0-PARP(78))**MINT(31)
22186 IF (PYR(0).LE.PKEEP) THEN
22194 C...Loop over event record, starting from IP
22195 C...(Ignore junctions for now.)
22203 DO 230 I=MAX(1,IP),N
22204 IF (K(I,1).NE.3) GOTO 230
22205 C...Check colour charge
22206 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22207 IF (MCI.EQ.0) GOTO 230
22208 C...For Seattle algorithm, only start from partons with one dangling
22210 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22211 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22213 C... Find optimal partner
22219 C...Loop over I colour/anticolour, check whether already connected
22221 IF (MCN(I,ICL).NE.0) GOTO 220
22222 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22223 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22224 C...Check whether this is a dangling colour tag (ie to junction!)
22226 DO 180 J=MAX(1,IP),N
22227 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22229 IF (IFOUND.EQ.0) GOTO 220
22230 DO 210 J=MAX(1,IP),N
22231 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22232 C...Do not make direct connections between partons in same Beam Remnant
22234 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22236 C...Check colour charge
22237 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22238 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22239 C...Check for gluon loops
22241 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22243 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22244 & MCN(I,ICLA).NE.0) MGGSTR=1
22246 C...Loop over J colour/anticolour, check whether already connected
22248 IF (MCN(J,JCL).NE.0) GOTO 200
22249 IF (JCL.EQ.ICL) GOTO 200
22250 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22251 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22252 C...Check whether this is a dangling colour tag (ie to junction!)
22254 DO 190 J2=MAX(1,IP),N
22255 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22258 IF (IFOUND.EQ.0) GOTO 200
22259 C...Save connection with smallest lambda measure
22260 C...If best so far was a BR string and this is not, also save.
22261 C...If best so far was a gg string and this is not, also save.
22263 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22264 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22265 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22277 IF (JLOPT.NE.0) THEN
22278 C...Save pair with largest RLOPT so far
22279 IF (RLOPT.GE.RLMAX) THEN
22290 C...Save and iterate
22291 IF (ILMAX.GT.0) THEN
22293 MCN(ILMAX,ICMAX)=LCT
22294 MCN(JLMAX,JCMAX)=LCT
22295 IF (NLOOP.LE.2*(N-IP)) THEN
22298 PRINT*, 'infinite loop!'
22302 C...Save and exit. First check for leftover gluon(s)
22303 DO 260 I=MAX(1,IP),N
22304 C...Check colour charge
22305 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22306 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22307 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22308 C...Decide where to put left-over gluon (minimal insertion)
22311 DO 250 KCT=NCT+1,LCT
22312 DO 240 IT=MAX(1,IP),N
22313 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22314 IF (MCN(IT,1).EQ.KCT) IC=IT
22315 IF (MCN(IT,2).EQ.KCT) IA=IT
22317 RL=FOUR(IC,I)*FOUR(IA,I)
22318 IF (RL.LT.RLMAX) THEN
22325 MCN(I,1)=MCN(ICMAX,1)
22330 DO 270 I=MAX(1,IP),N
22331 C...Do not erase parton shower colour history
22332 IF (K(I,1).NE.3) GOTO 270
22333 C...Check colour charge
22334 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22335 IF (MCI.EQ.0) GOTO 270
22336 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22337 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22344 C*********************************************************************
22347 C...Handles diffractive and elastic scattering.
22351 C...Double precision and integer declarations.
22352 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22353 IMPLICIT INTEGER(I-N)
22354 INTEGER PYK,PYCHGE,PYCOMP
22356 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22357 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22358 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22359 COMMON/PYINT1/MINT(400),VINT(400)
22360 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22362 C...Reset K, P and V vectors. Store incoming particles.
22363 DO 110 JT=1,MSTP(126)+10
22383 P(I,J)=VINT(285+5*JT+J)
22388 C...Subprocess; kinematics.
22389 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
22390 PZ=SQRT(SQLAM)/(2D0*VINT(1))
22393 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
22396 C...Elastically scattered particle. (Except elastic GVMD states.)
22397 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
22398 & MINT(106+JT).NE.3)) THEN
22403 P(N,3)=PZ*(-1)**(JT+1)
22405 P(N,5)=SQRT(VINT(62+JT))
22407 C...Decay rho from elastic scattering of gamma with sin**2(theta)
22408 C...distribution of decay products (in rho rest frame).
22409 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
22411 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
22415 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
22416 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
22417 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
22418 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
22419 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
22420 140 CTHE=2D0*PYR(0)-1D0
22421 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
22422 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
22424 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
22427 C...Diffracted particle: low-mass system to two particles.
22428 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
22434 PMMAS=SQRT(VINT(62+JT))
22437 IF(NTRY.LT.20) THEN
22438 MINT(105)=MINT(102+JT)
22439 MINT(109)=MINT(106+JT)
22440 CALL PYSPLI(KFH,21,KFL1,KFL2)
22441 CALL PYKFDI(KFL1,0,KFL3,KF1)
22442 IF(KF1.EQ.0) GOTO 150
22443 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
22444 IF(KF2.EQ.0) GOTO 150
22451 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
22456 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
22457 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
22460 P(N-1,4)=SQRT(PM1**2+PZP**2)
22461 P(N,4)=SQRT(PM2**2+PZP**2)
22462 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
22464 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
22465 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
22467 C...Diffracted particle: valence quark kicked out.
22468 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
22475 MINT(105)=MINT(102+JT)
22476 MINT(109)=MINT(106+JT)
22477 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
22478 P(N-1,5)=PYMASS(K(N-1,2))
22479 P(N,5)=PYMASS(K(N,2))
22480 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
22481 & 4D0*P(N-1,5)**2*P(N,5)**2
22482 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
22483 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
22484 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
22485 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
22486 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
22488 C...Diffracted particle: gluon kicked out.
22497 MINT(105)=MINT(102+JT)
22498 MINT(109)=MINT(106+JT)
22499 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
22501 P(N-2,5)=PYMASS(K(N-2,2))
22503 P(N,5)=PYMASS(K(N,2))
22504 C...Energy distribution for particle into two jets.
22506 IF(MOD(KFH/1000,10).NE.0) IMB=2
22507 CHIK=PARP(92+2*IMB)
22508 IF(MSTP(92).LE.1) THEN
22509 IF(IMB.EQ.1) CHI=PYR(0)
22510 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
22511 ELSEIF(MSTP(92).EQ.2) THEN
22512 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
22513 ELSEIF(MSTP(92).EQ.3) THEN
22514 CUT=2D0*0.3D0/VINT(1)
22516 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
22518 ELSEIF(MSTP(92).EQ.4) THEN
22519 CUT=2D0*0.3D0/VINT(1)
22520 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
22521 180 CHIR=CUT*CUTR**PYR(0)
22522 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
22523 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
22525 CUT=2D0*0.3D0/VINT(1)
22526 CUTA=CUT**(1D0-PARP(98))
22527 CUTB=(1D0+CUT)**(1D0-PARP(98))
22528 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
22529 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
22530 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
22532 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
22533 & VINT(62+JT)) GOTO 160
22534 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
22535 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
22536 & (2D0*VINT(62+JT))
22537 PEI=SQRT(PZI**2+SQM)
22538 PQQP=(1D0-CHI)*(PEI+PZI)
22539 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
22540 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
22541 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
22542 P(N-1,3)=P(N-1,4)*(-1)**JT
22543 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
22544 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
22547 C...Documentation lines.
22549 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
22550 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
22551 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
22553 P(I+2,3)=PZ*(-1)**(JT+1)
22555 P(I+2,5)=SQRT(VINT(62+JT))
22558 C...Rotate outgoing partons/particles using cos(theta).
22559 IF(VINT(23).LT.0.9D0) THEN
22560 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
22562 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
22568 C*********************************************************************
22571 C...Set up a DIS process as gamma* + f -> f, with beam remnant
22572 C...and showering added consecutively. Photon flux by the PYGAGA
22573 C...routine (if at all).
22577 C...Double precision and integer declarations.
22578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22579 IMPLICIT INTEGER(I-N)
22580 INTEGER PYK,PYCHGE,PYCOMP
22581 C...Parameter statement to help give large particle numbers.
22582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22583 &KEXCIT=4000000,KDIMEN=5000000)
22585 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22588 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22590 COMMON/PYINT1/MINT(400),VINT(400)
22591 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
22595 C...Choice of subprocess, number of documentation lines
22603 IF(MINT(107).EQ.4) ISIDE=2
22605 C...Reset K, P and V vectors. Store incoming particles
22606 DO 110 JT=1,MSTP(126)+20
22619 P(I,J)=VINT(285+5*JT+J)
22624 C...Store incoming partons in hadronic CM-frame
22629 K(I,3)=MINT(83)+2+JT
22631 IF(MINT(15).EQ.22) THEN
22632 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
22633 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
22634 P(MINT(84)+1,5)=-SQRT(VINT(307))
22635 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
22636 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
22640 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
22641 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
22642 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
22643 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
22644 P(MINT(84)+1,5)=-SQRT(VINT(308))
22648 SIDESG=(-1D0)**(ISIDE-1)
22650 C...Copy incoming partons to documentation lines.
22661 C...Second copy for partons before ISR shower, since no such.
22671 C...Define initial partons.
22674 IF(NTRY.GT.100) THEN
22679 C...Scattered quark in hadronic CM frame.
22684 P(IPU3,5)=PYMASS(KFRES)
22685 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
22686 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
22690 K(I,3)=MINT(83)+4+ISIDE
22698 C...No primordial kT, or chosen according to truncated Gaussian or
22699 C...exponential, or (for photon) predetermined or power law.
22700 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
22701 IF(MSTP(91).LE.0) THEN
22703 ELSEIF(MSTP(91).EQ.1) THEN
22704 PT=PARP(91)*SQRT(-LOG(PYR(0)))
22708 PT=-PARP(92)*LOG(RPT1*RPT2)
22710 IF(PT.GT.PARP(93)) GOTO 190
22711 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
22712 PTA=SQRT(VINT(282+ISIDE))
22714 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
22715 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
22716 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
22719 PTB=-PARP(99)*LOG(RPT1*RPT2)
22721 IF(PTB.GT.PARP(100)) GOTO 190
22722 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
22723 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
22724 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
22725 IF(MSTP(93).LE.0) THEN
22727 ELSEIF(MSTP(93).EQ.1) THEN
22728 PT=PARP(99)*SQRT(-LOG(PYR(0)))
22729 ELSEIF(MSTP(93).EQ.2) THEN
22732 PT=-PARP(99)*LOG(RPT1*RPT2)
22733 ELSEIF(MSTP(93).EQ.3) THEN
22736 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
22740 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
22741 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
22743 IF(PT.GT.PARP(100)) GOTO 190
22749 P(IPU3,1)=PT*COS(PHI)
22750 P(IPU3,2)=PT*SIN(PHI)
22751 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
22752 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
22753 PCP=P(IPU3,4)+ABS(P(IPU3,3))
22755 C...Find one or two beam remnants.
22756 MINT(105)=MINT(102+ISIDE)
22757 MINT(109)=MINT(106+ISIDE)
22758 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
22759 IF(MINT(51).NE.0) THEN
22764 C...Store first remnant parton, with colour info and kinematics.
22768 K(I,3)=MINT(83)+ISIDE
22769 P(I,5)=PYMASS(K(I,2))
22770 KCOL=KCHG(PYCOMP(KFLSP),2)
22773 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
22774 K(I,KFLS+3)=MSTU(5)*IPU3
22775 K(IPU3,6-KFLS)=MSTU(5)*I
22778 IF(KFLCH.EQ.0) THEN
22781 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
22783 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
22784 PRP=P(I,4)+ABS(P(I,3))
22786 C...When extra remnant parton or hadron: store extra remnant.
22791 K(I,3)=MINT(83)+ISIDE
22792 P(I,5)=PYMASS(K(I,2))
22793 KCOL=KCHG(PYCOMP(KFLCH),2)
22796 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
22797 K(I,KFLS+3)=MSTU(5)*IPU3
22798 K(IPU3,6-KFLS)=MSTU(5)*I
22802 C...Relative transverse momentum when two remnants.
22805 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
22806 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
22807 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
22808 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
22809 P(I,1)=-P(IPU3,1)-P(I-1,1)
22810 P(I,2)=-P(IPU3,2)-P(I-1,2)
22811 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
22813 C...Relative distribution of energy for particle into jet plus particle.
22815 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
22816 IF(MSTP(94).LE.1) THEN
22817 IF(IMB.EQ.1) CHI=PYR(0)
22818 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
22819 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
22820 ELSEIF(MSTP(94).EQ.2) THEN
22821 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
22822 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
22823 ELSEIF(MSTP(94).EQ.3) THEN
22824 CALL PYZDIS(1,0,PMS(4),ZZ)
22827 CALL PYZDIS(1000,0,PMS(4),ZZ)
22831 C...Construct total transverse mass; reject if too large.
22832 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
22833 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
22834 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
22835 IF(LOOP.LT.10) GOTO 200
22838 VINT(158+ISIDE)=CHI
22840 C...Subdivide longitudinal momentum according to value selected above.
22841 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
22843 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
22844 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
22846 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
22847 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
22851 C...Boost current and remnant systems to correct frame.
22852 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
22853 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
22854 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
22856 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
22858 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
22859 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
22860 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
22861 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
22863 C...Let current quark shower; recoil but no showering by colour partner.
22864 QMAX=2D0*SQRT(VINT(309-ISIDE))
22869 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
22876 C*********************************************************************
22879 C...Handles the documentation of the process in MSTI and PARI,
22880 C...and also computes cross-sections based on accumulated statistics.
22884 C...Double precision and integer declarations.
22885 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22886 IMPLICIT INTEGER(I-N)
22887 INTEGER PYK,PYCHGE,PYCOMP
22889 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22890 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22891 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22892 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22893 COMMON/PYINT1/MINT(400),VINT(400)
22894 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22895 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
22896 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
22899 C...Calculate Monte Carlo estimates of cross-sections.
22901 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
22902 NGEN(0,3)=NGEN(0,3)+1
22905 IF(I.EQ.96.OR.I.EQ.97) THEN
22907 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
22908 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
22909 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
22910 & DBLE(NGEN(96,2)))
22911 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
22912 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
22913 & DBLE(NGEN(96,2)))
22914 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
22916 ELSEIF(NGEN(I,2).EQ.0) THEN
22917 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
22920 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
22923 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
22926 C...Rescale to known low-pT cross-section for standard QCD processes.
22927 IF(MSUB(95).EQ.1) THEN
22928 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
22929 & XSEC(68,3)+XSEC(95,3)
22930 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
22931 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
22933 XSEC(11,3)=FAC*XSEC(11,3)
22934 XSEC(12,3)=FAC*XSEC(12,3)
22935 XSEC(13,3)=FAC*XSEC(13,3)
22936 XSEC(28,3)=FAC*XSEC(28,3)
22937 XSEC(53,3)=FAC*XSEC(53,3)
22938 XSEC(68,3)=FAC*XSEC(68,3)
22939 XSEC(95,3)=FAC*XSEC(95,3)
22940 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
22944 C...Save information for gamma-p and gamma-gamma.
22945 IF(MINT(121).GT.1) THEN
22951 C...Reset information on hard interaction.
22957 C...Copy integer valued information from MINT into MSTI.
22961 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
22963 C...Store cross-section variables in PARI.
22965 PARI(2)=XSEC(0,3)/MINT(5)
22969 VINT(98)=VINT(98)+VINT(100)
22970 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
22972 C...Store kinematics variables in PARI.
22975 IF(ISUB.NE.95) THEN
22985 PARI(35)=PARI(33)-PARI(34)
22992 PARI(42)=2D0*VINT(47)/VINT(1)
22995 C...Store information on scattered partons in PARI.
22996 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
22999 PARI(36+IS)=P(I,3)/VINT(1)
23000 PARI(38+IS)=P(I,4)/VINT(1)
23001 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23002 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23003 & SQRT(PR),1D20)),P(I,3))
23004 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23005 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23006 & SQRT(PR),1D20)),P(I,3))
23007 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23008 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23009 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23013 C...Store sum up transverse and longitudinal momenta.
23014 PARI(65)=2D0*PARI(17)
23015 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23016 DO 150 I=MSTP(126)+1,N
23017 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23018 PT=SQRT(P(I,1)**2+P(I,2)**2)
23019 PARI(69)=PARI(69)+PT
23020 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23021 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23033 C...Store various other pieces of information into PARI.
23041 C...Store information on lepton -> lepton + gamma in PYGAGA.
23044 PARI(101)=VINT(301)
23045 PARI(102)=VINT(302)
23047 PARI(I)=VINT(I+202)
23050 C...Set information for PYTABU.
23051 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23054 ELSEIF(ISET(ISUB).EQ.5) THEN
23065 C*********************************************************************
23068 C...Performs transformations between different coordinate frames.
23070 SUBROUTINE PYFRAM(IFRAME)
23072 C...Double precision and integer declarations.
23073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23074 IMPLICIT INTEGER(I-N)
23075 INTEGER PYK,PYCHGE,PYCOMP
23077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23078 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23079 COMMON/PYINT1/MINT(400),VINT(400)
23080 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23082 C...Check that transformation can and should be done.
23083 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23084 &MINT(91).EQ.1)) THEN
23085 IF(IFRAME.EQ.MINT(6)) RETURN
23087 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23091 IF(MINT(6).EQ.1) THEN
23092 C...Transform from fixed target or user specified frame to
23093 C...overall CM frame.
23094 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23095 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23096 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23097 ELSEIF(MINT(6).EQ.3) THEN
23098 C...Transform from hadronic CM frame in DIS to overall CM frame.
23099 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23103 IF(IFRAME.EQ.1) THEN
23104 C...Transform from overall CM frame to fixed target or user specified
23106 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23107 ELSEIF(IFRAME.EQ.3) THEN
23108 C...Transform from overall CM frame to hadronic CM frame in DIS.
23109 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23110 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23111 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23114 C...Set information about new frame.
23118 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23119 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23125 C*********************************************************************
23128 C...Calculates full and partial widths of resonances.
23130 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23132 C...Double precision and integer declarations.
23133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23134 IMPLICIT INTEGER(I-N)
23135 INTEGER PYK,PYCHGE,PYCOMP
23136 C...Parameter statement to help give large particle numbers.
23137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23138 &KEXCIT=4000000,KDIMEN=5000000)
23140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23142 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23143 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23144 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23145 COMMON/PYINT1/MINT(400),VINT(400)
23146 COMMON/PYINT4/MWID(500),WIDS(500,5)
23147 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23148 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23149 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23150 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23151 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23152 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23153 C...Local arrays and saved variables.
23154 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23155 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23156 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23157 SAVE MOFSV,WIDWSV,WID2SV
23158 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23160 C...Compressed code and sign; mass.
23167 C...Reset width information.
23168 DO 110 I=0,MDCY(KC,3)
23175 C...Allow for fudge factor to rescale resonance width.
23177 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23178 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23179 IF(MSTP(110).EQ.KFLA) THEN
23181 ELSEIF(MSTP(110).EQ.-1) THEN
23182 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23183 ELSEIF(MSTP(110).EQ.-2) THEN
23188 C...Not to be treated as a resonance: return.
23189 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23198 C...Treatment as a resonance based on tabulated branching ratios.
23199 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23200 C...Loop over possible decay channels; skip irrelevant ones.
23201 DO 120 I=1,MDCY(KC,3)
23203 IF(MDME(IDC,1).LT.0) GOTO 120
23205 C...Read out decay products and nominal masses.
23208 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23212 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23218 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23222 C...Naive partial width and alternative threshold factors.
23223 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23224 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23225 & PM1+PM2+PM3.GE.SHR) THEN
23227 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23228 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23229 & 4D0*PM1**2*PM2**2))/SH
23230 ELSEIF(MDME(IDC,2).EQ.52) THEN
23231 PMA=MAX(PM1,PM2,PM3)
23232 PMC=MIN(PM1,PM2,PM3)
23233 PMB=PM1+PM2+PM3-PMA-PMC
23234 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23239 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23240 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23241 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23242 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23243 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23244 & ((1D0-PMBCN)*PMBCN*SH)
23245 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23246 WDTP(I)=WDTP(I)*SQRT(
23247 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23248 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23249 ELSEIF(MDME(IDC,2).EQ.53) THEN
23250 PMA=MAX(PM1,PM2,PM3)
23251 PMC=MIN(PM1,PM2,PM3)
23252 PMB=PM1+PM2+PM3-PMA-PMC
23253 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23258 FACACT=SQRT(MAX(0D0,
23259 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23260 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23261 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23262 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23263 & ((1D0-PMBCN)*PMBCN*SH)
23264 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23268 PMBCN=PMBC**2/PMR**2
23269 FACNOM=SQRT(MAX(0D0,
23270 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23271 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23272 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23273 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23274 & ((1D0-PMBCN)*PMBCN*PMR**2)
23275 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23277 WDTP(I)=FUDGE*WDTP(I)
23278 WDTP(0)=WDTP(0)+WDTP(I)
23280 C...Calculate secondary width (at most two identical/opposite).
23282 IF(MDME(IDC,1).GT.0) THEN
23283 IF(KFD2.EQ.KFD1) THEN
23284 IF(KCHG(KFC1,3).EQ.0) THEN
23286 ELSEIF(KFD1.GT.0) THEN
23292 WID2=WID2*WIDS(KFC3,2)
23293 ELSEIF(KFD3.LT.0) THEN
23294 WID2=WID2*WIDS(KFC3,3)
23296 ELSEIF(KFD2.EQ.-KFD1) THEN
23299 WID2=WID2*WIDS(KFC3,2)
23300 ELSEIF(KFD3.LT.0) THEN
23301 WID2=WID2*WIDS(KFC3,3)
23303 ELSEIF(KFD3.EQ.KFD1) THEN
23304 IF(KCHG(KFC1,3).EQ.0) THEN
23306 ELSEIF(KFD1.GT.0) THEN
23312 WID2=WID2*WIDS(KFC2,2)
23313 ELSEIF(KFD2.LT.0) THEN
23314 WID2=WID2*WIDS(KFC2,3)
23316 ELSEIF(KFD3.EQ.-KFD1) THEN
23319 WID2=WID2*WIDS(KFC2,2)
23320 ELSEIF(KFD2.LT.0) THEN
23321 WID2=WID2*WIDS(KFC2,3)
23323 ELSEIF(KFD3.EQ.KFD2) THEN
23324 IF(KCHG(KFC2,3).EQ.0) THEN
23326 ELSEIF(KFD2.GT.0) THEN
23332 WID2=WID2*WIDS(KFC1,2)
23333 ELSEIF(KFD1.LT.0) THEN
23334 WID2=WID2*WIDS(KFC1,3)
23336 ELSEIF(KFD3.EQ.-KFD2) THEN
23339 WID2=WID2*WIDS(KFC1,2)
23340 ELSEIF(KFD1.LT.0) THEN
23341 WID2=WID2*WIDS(KFC1,3)
23350 WID2=WID2*WIDS(KFC2,2)
23352 WID2=WID2*WIDS(KFC2,3)
23355 WID2=WID2*WIDS(KFC3,2)
23356 ELSEIF(KFD3.LT.0) THEN
23357 WID2=WID2*WIDS(KFC3,3)
23361 C...Store effective widths according to case.
23362 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23363 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23364 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23365 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23375 C...Here begins detailed dynamical calculation of resonance widths.
23376 C...Shared treatment of Higgs states.
23379 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23384 C...Common electroweak and strong constants.
23387 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
23390 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
23392 RADC=1D0+AS/PARU(1)
23396 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23397 RADCT=1D0-2.5D0*AS/PARU(1)
23398 DO 140 I=1,MDCY(KC,3)
23400 IF(MDME(IDC,1).LT.0) GOTO 140
23401 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23402 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23403 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
23405 IF(I.GE.4.AND.I.LE.7) THEN
23406 C...t -> W + q; including approximate QCD correction factor.
23407 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
23408 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23409 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23412 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
23415 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
23417 ELSEIF(I.EQ.9) THEN
23419 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
23420 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23421 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
23422 & 4D0*SQRT(RM2R*RM2))
23424 IF(KFLR.LT.0) WID2=WIDS(37,3)
23426 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
23427 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
23430 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
23433 KFC1=PYCOMP(KFDP(IDC,1))
23434 KFC2=PYCOMP(KFDP(IDC,2))
23435 PMNCHI=PMAS(KFC1,1)
23436 PMSTOP=PMAS(KFC2,1)
23437 IF(SHR.GT.PMNCHI+PMSTOP) THEN
23440 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
23442 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
23443 AR=-ET*ZMIXC(IZ,1)*TANW
23444 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
23446 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
23447 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
23448 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
23449 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
23450 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
23451 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
23452 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
23454 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
23456 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
23459 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
23461 KFC1=PYCOMP(KFDP(IDC,1))
23462 KFC2=PYCOMP(KFDP(IDC,2))
23463 PMNCHI=PMAS(KFC1,1)
23464 PMSTOP=PMAS(KFC2,1)
23465 IF(SHR.GT.PMNCHI+PMSTOP) THEN
23468 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
23469 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
23470 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
23471 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
23473 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
23475 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
23478 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
23479 C...t -> ~gravitino + ~t
23481 KFC1=PYCOMP(KFDP(IDC,1))
23482 XMGR2=PMAS(KFC1,1)**2
23483 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
23484 KFC2=PYCOMP(KFDP(IDC,2))
23486 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
23489 WDTP(I)=FUDGE*WDTP(I)
23490 WDTP(0)=WDTP(0)+WDTP(I)
23491 IF(MDME(IDC,1).GT.0) THEN
23492 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23493 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23494 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23495 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23499 ELSEIF(KFLA.EQ.7) THEN
23501 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23502 DO 150 I=1,MDCY(KC,3)
23504 IF(MDME(IDC,1).LT.0) GOTO 150
23505 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23506 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23507 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
23509 IF(I.GE.4.AND.I.LE.7) THEN
23511 WDTP(I)=FAC*VCKM(I-3,4)*
23512 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23513 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23516 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
23517 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
23520 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
23521 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
23524 IF(KFLR.LT.0) WID2=WIDS(24,2)
23525 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
23527 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23528 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
23531 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
23534 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
23537 WDTP(I)=FUDGE*WDTP(I)
23538 WDTP(0)=WDTP(0)+WDTP(I)
23539 IF(MDME(IDC,1).GT.0) THEN
23540 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23541 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23542 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23543 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23547 ELSEIF(KFLA.EQ.8) THEN
23549 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23550 DO 160 I=1,MDCY(KC,3)
23552 IF(MDME(IDC,1).LT.0) GOTO 160
23553 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23554 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23555 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
23557 IF(I.GE.4.AND.I.LE.7) THEN
23559 WDTP(I)=FAC*VCKM(4,I-3)*
23560 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23561 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23564 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
23567 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
23569 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
23571 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23572 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
23575 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
23578 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
23581 WDTP(I)=FUDGE*WDTP(I)
23582 WDTP(0)=WDTP(0)+WDTP(I)
23583 IF(MDME(IDC,1).GT.0) THEN
23584 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23585 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23586 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23587 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23591 ELSEIF(KFLA.EQ.17) THEN
23593 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23594 DO 170 I=1,MDCY(KC,3)
23596 IF(MDME(IDC,1).LT.0) GOTO 170
23597 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23598 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23599 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
23602 C...tau' -> W + nu'_tau.
23603 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23604 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23607 WID2=WID2*WIDS(18,2)
23610 WID2=WID2*WIDS(18,3)
23612 ELSEIF(I.EQ.5) THEN
23613 C...tau' -> H + nu'_tau.
23614 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23615 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
23618 WID2=WID2*WIDS(18,2)
23621 WID2=WID2*WIDS(18,3)
23624 WDTP(I)=FUDGE*WDTP(I)
23625 WDTP(0)=WDTP(0)+WDTP(I)
23626 IF(MDME(IDC,1).GT.0) THEN
23627 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23628 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23629 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23630 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23634 ELSEIF(KFLA.EQ.18) THEN
23635 C...nu'_tau neutrino.
23636 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23637 DO 180 I=1,MDCY(KC,3)
23639 IF(MDME(IDC,1).LT.0) GOTO 180
23640 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23641 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23642 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
23645 C...nu'_tau -> W + tau'.
23646 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23647 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23650 WID2=WID2*WIDS(17,2)
23653 WID2=WID2*WIDS(17,3)
23655 ELSEIF(I.EQ.3) THEN
23656 C...nu'_tau -> H + tau'.
23657 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23658 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
23661 WID2=WID2*WIDS(17,2)
23664 WID2=WID2*WIDS(17,3)
23667 WDTP(I)=FUDGE*WDTP(I)
23668 WDTP(0)=WDTP(0)+WDTP(I)
23669 IF(MDME(IDC,1).GT.0) THEN
23670 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23671 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23672 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23673 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23677 ELSEIF(KFLA.EQ.21) THEN
23679 C***Note that widths are not given in dimensional quantities here.
23680 DO 190 I=1,MDCY(KC,3)
23682 IF(MDME(IDC,1).LT.0) GOTO 190
23683 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23684 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23685 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
23688 C...QCD -> q + qbar
23689 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23690 IF(I.EQ.6) WID2=WIDS(6,1)
23691 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23693 WDTP(I)=FUDGE*WDTP(I)
23694 WDTP(0)=WDTP(0)+WDTP(I)
23695 IF(MDME(IDC,1).GT.0) THEN
23696 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23697 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23698 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23699 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23703 ELSEIF(KFLA.EQ.22) THEN
23705 C***Note that widths are not given in dimensional quantities here.
23706 DO 200 I=1,MDCY(KC,3)
23708 IF(MDME(IDC,1).LT.0) GOTO 200
23709 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23710 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23711 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
23714 C...QED -> q + qbar.
23717 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
23718 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23719 IF(I.EQ.6) WID2=WIDS(6,1)
23720 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23721 ELSEIF(I.LE.12) THEN
23722 C...QED -> l+ + l-.
23723 EF=KCHG(9+2*(I-8),1)/3D0
23724 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23725 IF(I.EQ.12) WID2=WIDS(17,1)
23727 WDTP(I)=FUDGE*WDTP(I)
23728 WDTP(0)=WDTP(0)+WDTP(I)
23729 IF(MDME(IDC,1).GT.0) THEN
23730 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23731 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23732 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23733 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23737 ELSEIF(KFLA.EQ.23) THEN
23740 XWC=1D0/(16D0*XW*XW1)
23741 FAC=(AEM*XWC/3D0)*SHR
23743 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
23748 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
23750 IF(KFI.GT.20) KFI=IABS(MINT(16))
23756 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
23757 IF(MSTP(43).EQ.3) VINT(112)=
23758 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
23759 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
23760 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
23762 DO 220 I=1,MDCY(KC,3)
23764 IF(MDME(IDC,1).LT.0) GOTO 220
23765 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23766 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23767 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
23772 AF=SIGN(1D0,EF+0.1D0)
23775 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
23776 IF(I.EQ.6) WID2=WIDS(6,1)
23777 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23778 ELSEIF(I.LE.16) THEN
23779 C...Z0 -> l+ + l-, nu + nubar
23781 AF=SIGN(1D0,EF+0.1D0)
23784 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
23786 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
23787 IF(ICASE.EQ.1) THEN
23788 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
23790 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
23791 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
23792 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
23793 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
23794 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
23795 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
23796 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
23797 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
23799 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
23800 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
23801 IF(MDME(IDC,1).GT.0) THEN
23802 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
23803 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
23804 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23805 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
23806 & WDTE(I,MDME(IDC,1))
23807 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23808 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23810 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
23811 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
23812 & VINT(111)+FGGF*WID2
23813 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
23814 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
23815 & VINT(114)+FZZF*WID2
23819 IF(MINT(61).GE.1) ICASE=3-ICASE
23820 IF(ICASE.EQ.2) GOTO 210
23822 ELSEIF(KFLA.EQ.24) THEN
23824 FAC=(AEM/(24D0*XW))*SHR
23825 DO 230 I=1,MDCY(KC,3)
23827 IF(MDME(IDC,1).LT.0) GOTO 230
23828 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23829 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23830 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
23833 C...W+/- -> q + qbar'
23834 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
23836 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
23837 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
23838 IF(I.GE.13) WID2=WID2*WIDS(7,3)
23840 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
23841 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
23842 IF(I.GE.13) WID2=WID2*WIDS(7,2)
23844 ELSEIF(I.LE.20) THEN
23845 C...W+/- -> l+/- + nu
23848 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
23850 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
23853 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
23854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
23855 WDTP(I)=FUDGE*WDTP(I)
23856 WDTP(0)=WDTP(0)+WDTP(I)
23857 IF(MDME(IDC,1).GT.0) THEN
23858 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23859 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23860 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23861 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23865 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23866 C...h0 (or H0, or A0):
23868 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
23869 DO 270 I=1,MDCY(KFHIGG,3)
23870 IDC=I+MDCY(KFHIGG,2)-1
23871 IF(MDME(IDC,1).LT.0) GOTO 270
23872 KFC1=PYCOMP(KFDP(IDC,1))
23873 KFC2=PYCOMP(KFDP(IDC,2))
23874 RM1=PMAS(KFC1,1)**2/SH
23875 RM2=PMAS(KFC2,1)**2/SH
23876 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
23882 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
23883 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
23884 C...A0 behaves like beta, ho and H0 like beta**3.
23885 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
23886 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23887 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
23888 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
23889 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
23890 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
23891 IF(IHIGG.NE.3) THEN
23892 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23893 & PARU(151+10*IHIGG))**2
23897 IF(I.EQ.6) WID2=WIDS(6,1)
23898 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23899 ELSEIF(I.LE.12) THEN
23901 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
23902 C...A0 behaves like beta, ho and H0 like beta**3.
23903 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
23904 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
23905 & PARU(153+10*IHIGG)**2
23906 IF(I.EQ.12) WID2=WIDS(17,1)
23908 ELSEIF(I.EQ.13) THEN
23909 C...h0 -> g + g; quark loop contribution only
23912 DO 240 J=1,2*MSTP(1)
23913 EPS=(2D0*PMAS(J,1))**2/SH
23914 C...Loop integral; function of eps=4m^2/shat; different for A0.
23915 IF(EPS.LE.1D0) THEN
23916 IF(EPS.GT.1D-4) THEN
23918 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
23920 RLN=LOG(4D0/EPS-2D0)
23922 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
23923 PHIIM=0.5D0*PARU(1)*RLN
23925 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
23928 IF(IHIGG.LE.2) THEN
23929 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
23930 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
23932 ETAREJ=-0.5D0*EPS*PHIRE
23933 ETAIMJ=-0.5D0*EPS*PHIIM
23935 C...Couplings (=1 for standard model Higgs).
23936 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23937 IF(MOD(J,2).EQ.1) THEN
23938 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
23939 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
23941 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
23942 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
23948 ETA2=ETARE**2+ETAIM**2
23949 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
23951 ELSEIF(I.EQ.14) THEN
23952 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
23956 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
23958 IF(J.LE.2*MSTP(1)) THEN
23960 EPS=(2D0*PMAS(J,1))**2/SH
23961 ELSEIF(J.LE.3*MSTP(1)) THEN
23962 JL=2*(J-2*MSTP(1))-1
23963 EJ=KCHG(10+JL,1)/3D0
23964 EPS=(2D0*PMAS(10+JL,1))**2/SH
23965 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
23966 EPS=(2D0*PMAS(24,1))**2/SH
23968 EPS=(2D0*PMAS(37,1))**2/SH
23970 C...Loop integral; function of eps=4m^2/shat.
23971 IF(EPS.LE.1D0) THEN
23972 IF(EPS.GT.1D-4) THEN
23974 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
23976 RLN=LOG(4D0/EPS-2D0)
23978 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
23979 PHIIM=0.5D0*PARU(1)*RLN
23981 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
23984 IF(J.LE.3*MSTP(1)) THEN
23985 C...Fermion loops: loop integral different for A0; charges.
23986 IF(IHIGG.LE.2) THEN
23987 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
23988 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
23990 PHIPRE=-0.5D0*EPS*PHIRE
23991 PHIPIM=-0.5D0*EPS*PHIIM
23993 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
23995 EJH=PARU(151+10*IHIGG)
23996 ELSEIF(J.LE.2*MSTP(1)) THEN
23998 EJH=PARU(152+10*IHIGG)
24001 EJH=PARU(153+10*IHIGG)
24003 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24004 ETAREJ=EJC*EJH*PHIPRE
24005 ETAIMJ=EJC*EJH*PHIPIM
24006 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24007 C...W loops: loop integral and charges.
24008 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24009 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24010 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24011 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24012 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24015 C...Charged H loops: loop integral and charges.
24016 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24017 & PARU(158+10*IHIGG+2*(IHIGG/3))
24018 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24019 ETAIMJ=-EPS**2*PHIIM*FACHHH
24024 ETA2=ETARE**2+ETAIM**2
24025 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24027 ELSEIF(I.EQ.15) THEN
24028 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24032 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24034 IF(J.LE.2*MSTP(1)) THEN
24036 AJ=SIGN(1D0,EJ+0.1D0)
24038 EPS=(2D0*PMAS(J,1))**2/SH
24039 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24040 ELSEIF(J.LE.3*MSTP(1)) THEN
24041 JL=2*(J-2*MSTP(1))-1
24042 EJ=KCHG(10+JL,1)/3D0
24043 AJ=SIGN(1D0,EJ+0.1D0)
24045 EPS=(2D0*PMAS(10+JL,1))**2/SH
24046 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24048 EPS=(2D0*PMAS(24,1))**2/SH
24049 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24051 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24052 IF(EPS.LE.1D0) THEN
24054 IF(EPS.GT.1D-4) THEN
24055 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24057 RLN=LOG(4D0/EPS-2D0)
24059 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24060 PHIIM=0.5D0*PARU(1)*RLN
24061 PSIRE=0.5D0*ROOT*RLN
24062 PSIIM=-0.5D0*ROOT*PARU(1)
24064 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24066 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24069 IF(EPSP.LE.1D0) THEN
24070 ROOT=SQRT(1D0-EPSP)
24071 IF(EPSP.GT.1D-4) THEN
24072 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24074 RLN=LOG(4D0/EPSP-2D0)
24076 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24077 PHIIMP=0.5D0*PARU(1)*RLN
24078 PSIREP=0.5D0*ROOT*RLN
24079 PSIIMP=-0.5D0*ROOT*PARU(1)
24081 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24083 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24086 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24087 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24088 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24089 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24090 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24091 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24092 IF(J.LE.3*MSTP(1)) THEN
24093 C...Fermion loops: loop integral different for A0; charges.
24094 IF(IHIGG.EQ.3) FXYRE=0D0
24095 IF(IHIGG.EQ.3) FXYIM=0D0
24096 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24098 EJH=PARU(151+10*IHIGG)
24099 ELSEIF(J.LE.2*MSTP(1)) THEN
24101 EJH=PARU(152+10*IHIGG)
24104 EJH=PARU(153+10*IHIGG)
24106 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24107 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24108 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24109 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24110 C...W loops: loop integral and charges.
24111 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24112 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24113 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24114 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24115 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24116 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24119 C...Charged H loops: loop integral and charges.
24120 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24121 & PARU(158+10*IHIGG+2*(IHIGG/3))
24122 ETAREJ=FACHHH*FXYRE
24123 ETAIMJ=FACHHH*FXYIM
24128 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24129 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24132 ELSEIF(I.LE.17) THEN
24133 C...h0 -> Z0 + Z0, W+ + W-
24134 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24135 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24136 IF(MINT(62).GE.1) THEN
24137 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24138 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24139 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24140 MOFSV(IHIGG,I-15)=0
24141 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24145 MOFSV(IHIGG,I-15)=1
24146 RMAS=SQRT(MAX(0D0,SH))
24147 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24149 WIDWSV(IHIGG,I-15)=WIDW
24150 WID2SV(IHIGG,I-15)=WID2
24153 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24154 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24158 WIDW=WIDWSV(IHIGG,I-15)
24159 WID2=WID2SV(IHIGG,I-15)
24162 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24163 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24164 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24165 & PARU(138+I+10*IHIGG)**2
24166 WID2=WID2*WIDS(7+I,1)
24168 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24169 C...H0 -> Z0 + h0, A0-> Z0 + h0
24170 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24171 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24172 IF(IHIGG.EQ.2) THEN
24173 WDTP(I)=WDTP(I)*PARU(179)**2
24174 ELSEIF(IHIGG.EQ.3) THEN
24175 WDTP(I)=WDTP(I)*PARU(186)**2
24177 WID2=WIDS(23,2)*WIDS(25,2)
24179 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24180 C...H0 -> h0 + h0, A0-> h0 + h0
24181 WDTP(I)=FAC*0.25D0*
24182 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24183 IF(IHIGG.EQ.2) THEN
24184 WDTP(I)=WDTP(I)*PARU(176)**2
24185 ELSEIF(IHIGG.EQ.3) THEN
24186 WDTP(I)=WDTP(I)*PARU(169)**2
24189 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24190 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24191 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24192 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24193 & *PARU(195+IHIGG)**2
24195 WID2=WIDS(24,2)*WIDS(37,3)
24196 ELSEIF(I.EQ.21) THEN
24197 WID2=WIDS(24,3)*WIDS(37,2)
24200 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24202 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24203 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
24204 WID2=WIDS(36,2)*WIDS(23,2)
24206 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24208 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24209 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24210 WID2=WIDS(25,2)*WIDS(36,2)
24212 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24214 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24215 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24220 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24223 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24224 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24225 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24230 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24232 IF(KFC2.EQ.KFC1) THEN
24236 IF(KFDP(IDC,1).LT.0) KSGN1=3
24238 IF(KFDP(IDC,2).LT.0) KSGN2=3
24239 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24242 WDTP(I)=FUDGE*WDTP(I)
24243 WDTP(0)=WDTP(0)+WDTP(I)
24244 IF(MDME(IDC,1).GT.0) THEN
24245 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24246 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24247 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24248 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24252 ELSEIF(KFLA.EQ.32) THEN
24255 XWC=1D0/(16D0*XW*XW1)
24256 FAC=(AEM*XWC/3D0)*SHR
24259 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24267 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24268 KFAI=IABS(MINT(15))
24269 EI=KCHG(KFAI,1)/3D0
24270 AI=SIGN(1D0,EI+0.1D0)
24273 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24274 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24275 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24276 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24277 VPI=PARU(119+2*KFAIC)
24278 API=PARU(120+2*KFAIC)
24279 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24280 VPI=PARJ(178+2*KFAIC)
24281 API=PARJ(179+2*KFAIC)
24283 VPI=PARJ(186+2*KFAIC)
24284 API=PARJ(187+2*KFAIC)
24288 SQMZP=PMAS(32,1)**2
24290 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24291 & MSTP(44).EQ.7) VINT(111)=1D0
24292 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24293 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24294 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24295 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24296 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24297 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24298 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24299 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24300 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24301 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24302 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24304 DO 290 I=1,MDCY(KC,3)
24306 IF(MDME(IDC,1).LT.0) GOTO 290
24307 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24308 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24309 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24313 C...Z'0 -> q + qbar
24315 AF=SIGN(1D0,EF+0.1D0)
24318 VPF=PARU(123-2*MOD(I,2))
24319 APF=PARU(124-2*MOD(I,2))
24320 ELSEIF(I.LE.4) THEN
24321 VPF=PARJ(182-2*MOD(I,2))
24322 APF=PARJ(183-2*MOD(I,2))
24324 VPF=PARJ(190-2*MOD(I,2))
24325 APF=PARJ(191-2*MOD(I,2))
24328 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24329 & PYHFTH(SH,SH*RM1,1D0)
24330 IF(I.EQ.6) WID2=WIDS(6,1)
24331 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24332 ELSEIF(I.LE.16) THEN
24333 C...Z'0 -> l+ + l-, nu + nubar
24335 AF=SIGN(1D0,EF+0.1D0)
24338 VPF=PARU(127-2*MOD(I,2))
24339 APF=PARU(128-2*MOD(I,2))
24340 ELSEIF(I.LE.12) THEN
24341 VPF=PARJ(186-2*MOD(I,2))
24342 APF=PARJ(187-2*MOD(I,2))
24344 VPF=PARJ(194-2*MOD(I,2))
24345 APF=PARJ(195-2*MOD(I,2))
24348 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24350 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24351 IF(ICASE.EQ.1) THEN
24352 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24353 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24354 & APF**2*(1D0-4D0*RM1))*BE34
24355 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24356 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24357 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24358 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24359 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24360 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24361 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24362 ELSEIF(MINT(61).EQ.2) THEN
24363 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24364 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24365 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24366 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24367 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24369 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24372 ELSEIF(I.EQ.17) THEN
24374 WDTPZP=PARU(129)**2*XW1**2*
24375 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24376 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24377 IF(ICASE.EQ.1) THEN
24380 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24381 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24382 ELSEIF(MINT(61).EQ.2) THEN
24391 ELSEIF(I.EQ.18) THEN
24393 CZC=2D0*(1D0-2D0*XW)
24394 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24395 IF(ICASE.EQ.1) THEN
24396 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
24397 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
24398 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24399 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
24400 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
24401 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
24402 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
24403 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
24404 ELSEIF(MINT(61).EQ.2) THEN
24406 FGZF=0.25D0*PARU(142)*CZC*BE34C
24407 FGZPF=0.25D0*PARU(143)*CZC*BE34C
24408 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
24409 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
24410 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
24413 ELSEIF(I.EQ.19) THEN
24414 C...Z'0 -> Z0 + gamma.
24415 ELSEIF(I.EQ.20) THEN
24417 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24418 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
24419 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
24420 IF(ICASE.EQ.1) THEN
24423 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24424 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24425 ELSEIF(MINT(61).EQ.2) THEN
24433 WID2=WIDS(23,2)*WIDS(25,2)
24434 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
24435 C...Z' -> h0 + A0 or H0 + A0.
24436 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24444 IF(ICASE.EQ.1) THEN
24445 WDTPZ=CZAH**2*BE34C
24446 WDTP(I)=FAC*CZPAH**2*BE34C
24447 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24448 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
24449 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
24451 ELSEIF(MINT(61).EQ.2) THEN
24456 FZZPF=CZAH*CZPAH*BE34C
24457 FZPZPF=CZPAH**2*BE34C
24459 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
24460 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
24462 IF(ICASE.EQ.1) THEN
24463 VINT(117)=VINT(117)+FAC*WDTPZ
24464 WDTP(I)=FUDGE*WDTP(I)
24465 WDTP(0)=WDTP(0)+WDTP(I)
24467 IF(MDME(IDC,1).GT.0) THEN
24468 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24469 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24470 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24471 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24472 & WDTE(I,MDME(IDC,1))
24473 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24474 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24476 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24477 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24478 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
24479 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
24481 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
24483 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24484 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
24485 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
24487 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24488 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
24492 IF(MINT(61).GE.1) ICASE=3-ICASE
24493 IF(ICASE.EQ.2) GOTO 280
24495 ELSEIF(KFLA.EQ.34) THEN
24497 FAC=(AEM/(24D0*XW))*SHR
24498 DO 300 I=1,MDCY(KC,3)
24500 IF(MDME(IDC,1).LT.0) GOTO 300
24501 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24502 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
24507 C...W'+/- -> q + qbar'
24508 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
24509 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
24511 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24512 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24513 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24515 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24516 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24517 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24519 ELSEIF(I.LE.20) THEN
24520 C...W'+/- -> l+/- + nu
24521 FCOF=PARU(133)**2+PARU(134)**2
24523 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24525 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24528 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
24529 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24530 ELSEIF(I.EQ.21) THEN
24531 C...W'+/- -> W+/- + Z0
24532 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
24533 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24534 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24535 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
24536 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
24537 ELSEIF(I.EQ.23) THEN
24538 C...W'+/- -> W+/- + h0
24539 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24540 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
24541 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
24542 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
24544 WDTP(I)=FUDGE*WDTP(I)
24545 WDTP(0)=WDTP(0)+WDTP(I)
24546 IF(MDME(IDC,1).GT.0) THEN
24547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24554 ELSEIF(KFLA.EQ.37) THEN
24556 C IF(MSTP(49).EQ.0) THEN
24559 C SHFS=PMAS(37,1)**2
24561 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24562 DO 310 I=1,MDCY(KC,3)
24564 IF(MDME(IDC,1).LT.0) GOTO 310
24565 KFC1=PYCOMP(KFDP(IDC,1))
24566 KFC2=PYCOMP(KFDP(IDC,2))
24567 RM1=PMAS(KFC1,1)**2/SH
24568 RM2=PMAS(KFC2,1)**2/SH
24569 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
24572 C...H+/- -> q + qbar'
24573 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
24574 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24575 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
24576 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
24577 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
24579 IF(I.EQ.3) WID2=WIDS(6,2)
24580 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
24582 IF(I.EQ.3) WID2=WIDS(6,3)
24583 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
24585 ELSEIF(I.LE.8) THEN
24586 C...H+/- -> l+/- + nu
24587 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
24588 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
24589 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
24591 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
24593 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
24595 ELSEIF(I.EQ.9) THEN
24596 C...H+/- -> W+/- + h0.
24597 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
24598 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24599 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
24600 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
24604 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24607 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24608 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24609 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24614 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24617 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
24619 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
24620 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24622 WDTP(I)=FUDGE*WDTP(I)
24623 WDTP(0)=WDTP(0)+WDTP(I)
24624 IF(MDME(IDC,1).GT.0) THEN
24625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24632 ELSEIF(KFLA.EQ.41) THEN
24634 FAC=(AEM/(12D0*XW))*SHR
24635 DO 320 I=1,MDCY(KC,3)
24637 IF(MDME(IDC,1).LT.0) GOTO 320
24638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
24645 ELSEIF(I.LE.9) THEN
24649 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24650 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24652 IF(I.EQ.4) WID2=WIDS(6,3)
24653 IF(I.EQ.5) WID2=WIDS(7,3)
24654 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
24655 IF(I.EQ.9) WID2=WIDS(17,3)
24657 IF(I.EQ.4) WID2=WIDS(6,2)
24658 IF(I.EQ.5) WID2=WIDS(7,2)
24659 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
24660 IF(I.EQ.9) WID2=WIDS(17,2)
24662 WDTP(I)=FUDGE*WDTP(I)
24663 WDTP(0)=WDTP(0)+WDTP(I)
24664 IF(MDME(IDC,1).GT.0) THEN
24665 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24666 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24667 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24668 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24672 ELSEIF(KFLA.EQ.42) THEN
24673 C...LQ (leptoquark).
24674 FAC=(AEM/4D0)*PARU(151)*SHR
24675 DO 330 I=1,MDCY(KC,3)
24677 IF(MDME(IDC,1).LT.0) GOTO 330
24678 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24679 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24680 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
24681 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24683 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
24684 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
24685 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
24686 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
24687 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
24688 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
24689 WDTP(I)=FUDGE*WDTP(I)
24690 WDTP(0)=WDTP(0)+WDTP(I)
24691 IF(MDME(IDC,1).GT.0) THEN
24692 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24693 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24694 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24695 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24699 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
24700 C...Techni-pi0 and techni-pi0':
24701 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
24702 DO 340 I=1,MDCY(KC,3)
24704 IF(MDME(IDC,1).LT.0) GOTO 340
24705 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
24706 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
24709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
24713 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
24714 & /(8D0*PARU(1))*SH*SHR
24715 IF(KFLA.EQ.KTECHN+111) THEN
24722 C...pi_tc -> f + fbar.
24724 IKA=IABS(KFDP(IDC,1))
24725 IF(IKA.LT.10) FCOF=3D0*RADC
24728 IF(IKA.GE.4.AND.IKA.LE.6) THEN
24729 FCOF=FCOF*RTCM(1+IKA)**2
24730 HM1=PYMRUN(KFDP(IDC,1),SH)
24731 HM2=PYMRUN(KFDP(IDC,2),SH)
24732 ELSEIF(IKA.EQ.15) THEN
24733 FCOF=FCOF*RTCM(8)**2
24735 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
24736 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24738 WDTP(I)=FUDGE*WDTP(I)
24739 WDTP(0)=WDTP(0)+WDTP(I)
24740 IF(MDME(IDC,1).GT.0) THEN
24741 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24742 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24743 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24744 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24748 ELSEIF(KFLA.EQ.KTECHN+211) THEN
24750 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
24751 DO 350 I=1,MDCY(KC,3)
24753 IF(MDME(IDC,1).LT.0) GOTO 350
24754 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
24755 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
24757 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
24761 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
24763 C...pi_tc -> f + f'.
24765 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
24766 C...pi_tc+ -> W b b~
24767 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
24769 XMT2=PMAS(6,1)**2/SH
24770 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
24771 KFC3=PYCOMP(KFDP(IDC,3))
24772 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
24774 T0 = (1D0-CHECK**2)*
24775 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
24776 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
24777 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
24778 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
24779 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
24780 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
24789 IKA=IABS(KFDP(IDC,1))
24790 IF(IKA.LT.10) FCOF=3D0*RADC
24793 IF(I.GE.1.AND.I.LE.5) THEN
24795 FCOF=FCOF*RTCM(5)**2
24796 ELSEIF(I.LE.4) THEN
24797 FCOF=FCOF*RTCM(6)**2
24798 ELSEIF(I.EQ.5) THEN
24799 FCOF=FCOF*RTCM(7)**2
24801 HM1=PYMRUN(KFDP(IDC,1),SH)
24802 HM2=PYMRUN(KFDP(IDC,2),SH)
24803 ELSEIF(I.EQ.8) THEN
24804 FCOF=FCOF*RTCM(8)**2
24806 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
24807 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24809 WDTP(I)=FUDGE*WDTP(I)
24810 WDTP(0)=WDTP(0)+WDTP(I)
24811 IF(MDME(IDC,1).GT.0) THEN
24812 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24813 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24814 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24815 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24819 ELSEIF(KFLA.EQ.KTECHN+331) THEN
24821 FAC=(SH/PARP(46)**2)*SHR
24822 DO 360 I=1,MDCY(KC,3)
24824 IF(MDME(IDC,1).LT.0) GOTO 360
24825 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24826 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24827 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
24830 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
24831 IF(I.EQ.2) WID2=WIDS(6,1)
24833 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
24835 WDTP(I)=FUDGE*WDTP(I)
24836 WDTP(0)=WDTP(0)+WDTP(I)
24837 IF(MDME(IDC,1).GT.0) THEN
24838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24845 ELSEIF(KFLA.EQ.KTECHN+113) THEN
24847 ALPRHT=2.91D0*(3D0/ITCM(1))
24848 FAC=(ALPRHT/12D0)*SHR
24849 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
24853 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
24855 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
24856 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
24857 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
24858 DO 370 I=1,MDCY(KC,3)
24860 IF(MDME(IDC,1).LT.0) GOTO 370
24861 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24862 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24863 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
24866 C...rho_tc0 -> W+ + W-.
24867 WDTP(I)=FAC*RTCM(3)**4*
24868 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24870 ELSEIF(I.EQ.2) THEN
24871 C...rho_tc0 -> W+ + pi_tc-.
24872 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24873 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24874 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24875 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24876 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24877 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
24878 ELSEIF(I.EQ.3) THEN
24879 C...rho_tc0 -> pi_tc+ + W-.
24880 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24881 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24882 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24883 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24884 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24885 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
24886 ELSEIF(I.EQ.4) THEN
24887 C...rho_tc0 -> pi_tc+ + pi_tc-.
24888 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
24889 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24890 WID2=WIDS(PYCOMP(KTECHN+211),1)
24891 ELSEIF(I.EQ.5) THEN
24892 C...rho_tc0 -> gamma + pi_tc0
24893 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24894 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24896 WID2=WIDS(PYCOMP(KTECHN+111),2)
24897 ELSEIF(I.EQ.6) THEN
24898 C...rho_tc0 -> gamma + pi_tc0'
24899 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24900 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
24901 WID2=WIDS(PYCOMP(KTECHN+221),2)
24902 ELSEIF(I.EQ.7) THEN
24903 C...rho_tc0 -> Z0 + pi_tc0
24904 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24905 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24907 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
24908 ELSEIF(I.EQ.8) THEN
24909 C...rho_tc0 -> Z0 + pi_tc0'
24910 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24911 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
24913 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
24915 C...rho_tc0 -> f + fbar.
24920 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
24924 IF(IA.GE.17) WID2=WIDS(IA,1)
24927 AI=SIGN(1D0,EI+0.1D0)
24931 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
24932 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
24933 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
24934 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
24936 WDTP(I)=FUDGE*WDTP(I)
24937 WDTP(0)=WDTP(0)+WDTP(I)
24938 IF(MDME(IDC,1).GT.0) THEN
24939 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24940 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24941 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24942 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24946 ELSEIF(KFLA.EQ.KTECHN+213) THEN
24948 ALPRHT=2.91D0*(3D0/ITCM(1))
24949 FAC=(ALPRHT/12D0)*SHR
24953 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
24955 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
24956 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
24957 DO 380 I=1,MDCY(KC,3)
24959 IF(MDME(IDC,1).LT.0) GOTO 380
24960 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24961 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24962 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
24965 C...rho_tc+ -> W+ + Z0.
24966 WDTP(I)=FAC*RTCM(3)**4*
24967 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24969 WID2=WIDS(24,2)*WIDS(23,2)
24971 WID2=WIDS(24,3)*WIDS(23,2)
24973 ELSEIF(I.EQ.2) THEN
24974 C...rho_tc+ -> W+ + pi_tc0.
24975 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24976 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24977 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24978 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24979 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24981 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
24983 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
24985 ELSEIF(I.EQ.3) THEN
24986 C...rho_tc+ -> pi_tc+ + Z0.
24987 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24988 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24989 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24990 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
24991 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
24992 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24993 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24996 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
24998 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25000 ELSEIF(I.EQ.4) THEN
25001 C...rho_tc+ -> pi_tc+ + pi_tc0.
25002 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25003 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25005 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25007 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25009 ELSEIF(I.EQ.5) THEN
25010 C...rho_tc+ -> pi_tc+ + gamma
25011 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25012 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25015 WID2=WIDS(PYCOMP(KTECHN+211),2)
25017 WID2=WIDS(PYCOMP(KTECHN+211),3)
25019 ELSEIF(I.EQ.6) THEN
25020 C...rho_tc+ -> W+ + pi_tc0'
25021 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25022 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25024 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25026 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25029 C...rho_tc+ -> f + fbar'.
25033 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25035 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25036 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25037 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25039 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25040 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25041 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25046 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25048 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25051 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25052 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25054 WDTP(I)=FUDGE*WDTP(I)
25055 WDTP(0)=WDTP(0)+WDTP(I)
25056 IF(MDME(IDC,1).GT.0) THEN
25057 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25058 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25059 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25060 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25064 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25066 ALPRHT=2.91D0*(3D0/ITCM(1))
25067 FAC=(ALPRHT/12D0)*SHR
25068 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25071 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25073 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25074 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25075 DO 390 I=1,MDCY(KC,3)
25077 IF(MDME(IDC,1).LT.0) GOTO 390
25078 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25079 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25080 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25083 C...omega_tc0 -> gamma + pi_tc0.
25084 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25085 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25086 WID2=WIDS(PYCOMP(KTECHN+111),2)
25087 ELSEIF(I.EQ.2) THEN
25088 C...omega_tc0 -> Z0 + pi_tc0
25089 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25090 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25092 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25093 ELSEIF(I.EQ.3) THEN
25094 C...omega_tc0 -> gamma + pi_tc0'
25095 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25096 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25098 WID2=WIDS(PYCOMP(KTECHN+221),2)
25099 ELSEIF(I.EQ.4) THEN
25100 C...omega_tc0 -> Z0 + pi_tc0'
25101 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25102 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25104 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25105 ELSEIF(I.EQ.5) THEN
25106 C...omega_tc0 -> W+ + pi_tc-
25107 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25108 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25109 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25110 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25111 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25112 ELSEIF(I.EQ.6) THEN
25113 C...omega_tc0 -> pi_tc+ + W-
25114 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25115 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25116 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25117 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25118 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25119 ELSEIF(I.EQ.7) THEN
25120 C...omega_tc0 -> W+ + W-.
25121 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25122 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25124 ELSEIF(I.EQ.8) THEN
25125 C...omega_tc0 -> pi_tc+ + pi_tc-.
25126 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25128 WID2=WIDS(PYCOMP(KTECHN+211),1)
25130 C...omega_tc0 -> f + fbar.
25135 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25139 IF(IA.GE.17) WID2=WIDS(IA,1)
25142 AI=SIGN(1D0,EI+0.1D0)
25144 VALI=-0.5D0*(VI+AI)
25145 VARI=-0.5D0*(VI-AI)
25146 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25147 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25148 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25149 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25151 WDTP(I)=FUDGE*WDTP(I)
25152 WDTP(0)=WDTP(0)+WDTP(I)
25153 IF(MDME(IDC,1).GT.0) THEN
25154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25156 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25157 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25161 C.....V8 -> quark anti-quark
25162 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25165 IF(ITCM(2).EQ.0) THEN
25167 ELSEIF(ITCM(2).EQ.1) THEN
25170 DO 400 I=1,MDCY(KC,3)
25172 IF(MDME(IDC,1).LT.0) GOTO 400
25173 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25175 IF(RM1.GT.0.25D0) GOTO 400
25177 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25182 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25183 IF(I.EQ.6) WID2=WIDS(6,1)
25184 WDTP(I)=FUDGE*WDTP(I)
25185 WDTP(0)=WDTP(0)+WDTP(I)
25186 IF(MDME(IDC,1).GT.0) THEN
25187 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25188 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25189 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25190 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25194 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25195 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25197 DO 410 I=1,MDCY(KC,3)
25199 IF(MDME(IDC,1).LT.0) GOTO 410
25200 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25201 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25202 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25206 IF(KFLA.EQ.KTECHN+100111) THEN
25211 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25212 & /(2D0*PARU(1))*SH*SHR*CLEBG
25215 C...pi_tc -> f + fbar.
25216 IF(I.EQ.6) WID2=WIDS(6,1)
25218 IKA=IABS(KFDP(IDC,1))
25219 IF(IKA.LT.10) FCOF=3D0*RADC
25220 HM1=PYMRUN(KFDP(IDC,1),SH)
25221 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25222 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25224 WDTP(I)=FUDGE*WDTP(I)
25225 WDTP(0)=WDTP(0)+WDTP(I)
25226 IF(MDME(IDC,1).GT.0) THEN
25227 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25228 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25229 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25230 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25234 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25236 ALPRHT=2.91D0*(3D0/ITCM(1))
25238 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25239 SINT3=TANT3/SQRT(TANT3**2+1D0)
25242 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25243 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25244 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25245 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25246 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25248 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25250 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25252 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25254 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25255 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25256 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25257 IF(ITCM(2).EQ.0) THEN
25262 DO 420 I=1,MDCY(KC,3)
25263 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25264 & KFLA.EQ.KTECHN+300113)) GOTO 420
25266 IF(MDME(IDC,1).LT.0) GOTO 420
25267 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25268 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25269 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25272 IF(I.EQ.6) WID2=WIDS(6,1)
25274 IF(KFLA.EQ.KTECHN+200113) THEN
25277 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25280 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25285 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25286 FMIX=1D0/TANT3/SIN2T
25290 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25291 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25292 ELSEIF(I.EQ.7) THEN
25293 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25294 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25295 PSH=SHR*(1D0-RM1)/2D0
25296 WDTP(I)=AS/9D0*PSH**3/RM82
25298 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25299 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25301 WDTP(I)=5D0*WDTP(I)
25302 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25305 WDTP(I)=FUDGE*WDTP(I)
25306 WDTP(0)=WDTP(0)+WDTP(I)
25307 IF(MDME(IDC,1).GT.0) THEN
25308 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25309 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25310 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25311 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25315 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25316 C...d* excited quark.
25317 FAC=(SH/RTCM(41)**2)*SHR
25318 DO 430 I=1,MDCY(KC,3)
25320 IF(MDME(IDC,1).LT.0) GOTO 430
25321 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25322 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25323 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25327 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25329 ELSEIF(I.EQ.2) THEN
25330 C...d* -> gamma + d.
25331 QF=-RTCM(43)/2D0+RTCM(44)/6D0
25332 WDTP(I)=FAC*AEM*QF**2/4D0
25334 ELSEIF(I.EQ.3) THEN
25336 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25337 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25338 & (1D0-RM1)**2*(2D0+RM1)
25340 ELSEIF(I.EQ.4) THEN
25342 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25343 & (1D0-RM1)**2*(2D0+RM1)
25344 IF(KFLR.GT.0) WID2=WIDS(24,3)
25345 IF(KFLR.LT.0) WID2=WIDS(24,2)
25347 WDTP(I)=FUDGE*WDTP(I)
25348 WDTP(0)=WDTP(0)+WDTP(I)
25349 IF(MDME(IDC,1).GT.0) THEN
25350 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25351 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25352 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25353 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25357 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
25358 C...u* excited quark.
25359 FAC=(SH/RTCM(41)**2)*SHR
25360 DO 440 I=1,MDCY(KC,3)
25362 IF(MDME(IDC,1).LT.0) GOTO 440
25363 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25364 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25365 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
25369 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25371 ELSEIF(I.EQ.2) THEN
25372 C...u* -> gamma + u.
25373 QF=RTCM(43)/2D0+RTCM(44)/6D0
25374 WDTP(I)=FAC*AEM*QF**2/4D0
25376 ELSEIF(I.EQ.3) THEN
25378 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25379 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25380 & (1D0-RM1)**2*(2D0+RM1)
25382 ELSEIF(I.EQ.4) THEN
25384 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25385 & (1D0-RM1)**2*(2D0+RM1)
25386 IF(KFLR.GT.0) WID2=WIDS(24,2)
25387 IF(KFLR.LT.0) WID2=WIDS(24,3)
25389 WDTP(I)=FUDGE*WDTP(I)
25390 WDTP(0)=WDTP(0)+WDTP(I)
25391 IF(MDME(IDC,1).GT.0) THEN
25392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25399 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
25400 C...e* excited lepton.
25401 FAC=(SH/RTCM(41)**2)*SHR
25402 DO 450 I=1,MDCY(KC,3)
25404 IF(MDME(IDC,1).LT.0) GOTO 450
25405 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25406 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25407 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
25410 C...e* -> gamma + e.
25411 QF=-RTCM(43)/2D0-RTCM(44)/2D0
25412 WDTP(I)=FAC*AEM*QF**2/4D0
25414 ELSEIF(I.EQ.2) THEN
25416 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
25417 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25418 & (1D0-RM1)**2*(2D0+RM1)
25420 ELSEIF(I.EQ.3) THEN
25422 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25423 & (1D0-RM1)**2*(2D0+RM1)
25424 IF(KFLR.GT.0) WID2=WIDS(24,3)
25425 IF(KFLR.LT.0) WID2=WIDS(24,2)
25427 WDTP(I)=FUDGE*WDTP(I)
25428 WDTP(0)=WDTP(0)+WDTP(I)
25429 IF(MDME(IDC,1).GT.0) THEN
25430 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25431 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25432 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25433 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25437 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
25438 C...nu*_e excited neutrino.
25439 FAC=(SH/RTCM(41)**2)*SHR
25440 DO 460 I=1,MDCY(KC,3)
25442 IF(MDME(IDC,1).LT.0) GOTO 460
25443 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25444 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
25448 C...nu*_e -> Z0 + nu*_e.
25449 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
25450 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25451 & (1D0-RM1)**2*(2D0+RM1)
25453 ELSEIF(I.EQ.2) THEN
25454 C...nu*_e -> W+ + e.
25455 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25456 & (1D0-RM1)**2*(2D0+RM1)
25457 IF(KFLR.GT.0) WID2=WIDS(24,2)
25458 IF(KFLR.LT.0) WID2=WIDS(24,3)
25460 WDTP(I)=FUDGE*WDTP(I)
25461 WDTP(0)=WDTP(0)+WDTP(I)
25462 IF(MDME(IDC,1).GT.0) THEN
25463 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25464 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25465 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25466 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25470 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
25471 C...G* (graviton resonance):
25472 FAC=(PARP(50)**2/PARU(1))*SHR
25473 DO 470 I=1,MDCY(KC,3)
25475 IF(MDME(IDC,1).LT.0) GOTO 470
25476 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25477 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25478 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
25483 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25484 & PYHFTH(SH,SH*RM1,1D0)
25485 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
25486 & (1D0+8D0*RM1/3D0)/320D0
25487 IF(I.EQ.6) WID2=WIDS(6,1)
25488 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
25489 ELSEIF(I.LE.16) THEN
25490 C...G* -> l+ + l-, nu + nubar
25492 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
25493 & (1D0+8D0*RM1/3D0)/320D0
25494 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
25495 ELSEIF(I.EQ.17) THEN
25498 ELSEIF(I.EQ.18) THEN
25499 C...G* -> gamma + gamma.
25501 ELSEIF(I.EQ.19) THEN
25503 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
25504 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
25506 ELSEIF(I.EQ.20) THEN
25508 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
25509 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
25512 WDTP(I)=FUDGE*WDTP(I)
25513 WDTP(0)=WDTP(0)+WDTP(I)
25514 IF(MDME(IDC,1).GT.0) THEN
25515 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25516 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25517 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25518 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25522 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
25523 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
25524 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
25525 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
25526 DO 480 I=1,MDCY(KC,3)
25528 IF(MDME(IDC,1).LT.0) GOTO 480
25529 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25530 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25531 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25532 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
25535 C...nu_lR -> l- qbar q'
25536 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
25537 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
25538 ELSEIF(I.LE.18) THEN
25539 C...nu_lR -> l+ q qbar'
25540 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
25541 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
25543 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
25545 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
25547 X=(PM1+PM2+PM3)/SHR
25548 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
25550 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
25551 WDTP(I)=FAC*FCOF*FX*FY
25552 WDTP(I)=FUDGE*WDTP(I)
25553 WDTP(0)=WDTP(0)+WDTP(I)
25554 IF(MDME(IDC,1).GT.0) THEN
25555 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25556 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25557 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25558 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25562 ELSEIF(KFLA.EQ.9900023) THEN
25564 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
25565 DO 490 I=1,MDCY(KC,3)
25567 IF(MDME(IDC,1).LT.0) GOTO 490
25568 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25569 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25570 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
25574 C...Z_R0 -> q + qbar
25576 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
25577 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
25579 IF(I.EQ.6) WID2=WIDS(6,1)
25580 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
25581 C...Z_R0 -> l+ + l-
25585 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
25586 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
25591 ELSEIF(I.LE.15) THEN
25592 C...Z0 -> nu_R + nu_R, assumed Majorana.
25596 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
25599 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25600 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
25601 WDTP(I)=FUDGE*WDTP(I)
25602 WDTP(0)=WDTP(0)+WDTP(I)
25603 IF(MDME(IDC,1).GT.0) THEN
25604 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25605 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25606 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25607 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25611 ELSEIF(KFLA.EQ.9900024) THEN
25613 FAC=(AEM/(24D0*XW))*SHR
25614 DO 500 I=1,MDCY(KC,3)
25616 IF(MDME(IDC,1).LT.0) GOTO 500
25617 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25618 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25619 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
25622 C...W_R+/- -> q + qbar'
25623 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
25625 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
25627 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
25629 ELSEIF(I.LE.12) THEN
25630 C...W_R+/- -> l+/- + nu_R
25633 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25634 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25635 WDTP(I)=FUDGE*WDTP(I)
25636 WDTP(0)=WDTP(0)+WDTP(I)
25637 IF(MDME(IDC,1).GT.0) THEN
25638 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25639 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25640 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25641 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25645 ELSEIF(KFLA.EQ.9900041) THEN
25647 FAC=(1D0/(8D0*PARU(1)))*SHR
25648 DO 510 I=1,MDCY(KC,3)
25650 IF(MDME(IDC,1).LT.0) GOTO 510
25651 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25652 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25653 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
25656 C...H_L++/-- -> l+/- + l'+/-
25657 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
25658 & (IABS(KFDP(IDC,2))-9)/2)**2
25659 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
25660 ELSEIF(I.EQ.7) THEN
25661 C...H_L++/-- -> W_L+/- + W_L+/-
25662 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
25663 & (3D0*RM1+0.25D0/RM1-1D0)
25664 WID2=WIDS(24,4+(1-KFLS)/2)
25667 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25668 WDTP(I)=FUDGE*WDTP(I)
25669 WDTP(0)=WDTP(0)+WDTP(I)
25670 IF(MDME(IDC,1).GT.0) THEN
25671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25673 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25674 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25678 ELSEIF(KFLA.EQ.9900042) THEN
25680 FAC=(1D0/(8D0*PARU(1)))*SHR
25681 DO 520 I=1,MDCY(KC,3)
25683 IF(MDME(IDC,1).LT.0) GOTO 520
25684 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25685 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25686 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
25689 C...H_R++/-- -> l+/- + l'+/-
25690 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
25691 & (IABS(KFDP(IDC,2))-9)/2)**2
25692 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
25693 ELSEIF(I.EQ.7) THEN
25694 C...H_R++/-- -> W_R+/- + W_R+/-
25695 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
25696 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
25699 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25700 WDTP(I)=FUDGE*WDTP(I)
25701 WDTP(0)=WDTP(0)+WDTP(I)
25702 IF(MDME(IDC,1).GT.0) THEN
25703 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25704 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25705 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25706 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25717 C***********************************************************************
25720 C...Calculates partial width and differential cross-section maxima
25721 C...of channels/processes not allowed on mass-shell, and selects
25722 C...masses in such channels/processes.
25724 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
25726 C...Double precision and integer declarations.
25727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25728 IMPLICIT INTEGER(I-N)
25729 INTEGER PYK,PYCHGE,PYCOMP
25731 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25732 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25733 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25734 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25735 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25736 COMMON/PYINT1/MINT(400),VINT(400)
25737 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25738 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
25739 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25742 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
25743 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
25744 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
25747 C...Find if particles equal, maximum mass, matrix elements, etc.
25753 IF(KFD(1).EQ.KFD(2)) MEQL=1
25755 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
25756 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
25762 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
25765 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
25766 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
25767 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
25768 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
25769 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
25770 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
25773 C...Find where Breit-Wigners are required, else select discrete masses.
25775 KFCA=PYCOMP(KFD(I))
25777 PMD(I)=PMAS(KFCA,1)
25778 PGD(I)=PMAS(KFCA,2)
25783 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
25786 RMG(I)=(PMG(I)/PMMX)**2
25792 C...Find allowed mass range and Breit-Wigner parameters.
25794 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
25796 PMU(I)=PMMX-PARP(42)
25797 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
25798 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25799 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
25801 IF(MLM.EQ.2) ILM=3-I
25802 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
25803 IF(MBW(3-I).EQ.0) THEN
25804 PMU(I)=PMMX-PMD(3-I)
25806 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
25808 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
25809 & MIN(PMU(I),CKIN(NOFF+2*ILM))
25810 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
25811 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
25812 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25813 IF(MBW(I).EQ.1) THEN
25814 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25815 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25816 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
25819 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
25821 IF(MLM.EQ.2) ILM=3-I
25822 PML(I)=MAX(CKIN(48+I),PARP(42))
25823 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
25824 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
25825 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
25826 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
25827 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25828 IF(MBW(I).EQ.1) THEN
25829 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25830 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25831 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
25836 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
25838 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
25843 C...Calculation of partial width of resonance.
25844 IF(MOFSH.EQ.1) THEN
25846 C..If only one integration, pick that to be the inner.
25847 IF(MBW(1).EQ.0) THEN
25853 ELSEIF(MBW(2).EQ.0) THEN
25857 C...Start outer loop of integration.
25858 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25859 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
25860 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
25866 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25867 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
25868 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
25872 C...Start inner loop of integration.
25874 PMU1=MIN(PMU(1),PMMX-PM2)
25875 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
25876 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
25877 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
25878 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
25886 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
25887 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
25890 C...Evaluate function value - inner loop.
25891 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25892 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
25893 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
25894 & RM2**2+10D0*RM1*RM2)
25895 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
25898 C...Go to next position in inner loop.
25904 ELSEIF(NPT1.LE.8) THEN
25906 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
25908 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
25909 INX1(NPT1)=INX1(ISH1)
25912 ELSEIF(NPT1.LT.100) THEN
25915 IF(ISH1.GT.NPT1) ISH1=2
25916 IF(ISH1.EQ.ISN1) GOTO 160
25917 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
25918 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
25920 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
25921 INX1(NPT1)=INX1(ISH1)
25926 C...Calculate integral over inner loop.
25929 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
25930 & (XPT1(INX1(IPT1))-XPT1(IPT1))
25932 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
25933 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25934 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
25937 C...Go to next position in outer loop.
25943 ELSEIF(NPT2.LE.8) THEN
25945 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
25947 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
25948 INX2(NPT2)=INX2(ISH2)
25951 ELSEIF(NPT2.LT.100) THEN
25954 IF(ISH2.GT.NPT2) ISH2=2
25955 IF(ISH2.EQ.ISN2) GOTO 200
25956 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
25957 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
25959 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
25960 INX2(NPT2)=INX2(ISH2)
25965 C...Calculate integral over outer loop.
25968 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
25969 & (XPT2(INX2(IPT2))-XPT2(IPT2))
25971 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
25972 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
25977 C...Save result; second integration for user-selected mass range.
25978 IF(LOOP.EQ.1) WIDW=FSUM2
25980 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
25981 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
25988 C...Select two decay product masses of a resonance.
25989 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
25991 IF(MBW(I).EQ.0) GOTO 230
25992 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
25994 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
25995 RMG(I)=(PMG(I)/PMMX)**2
25997 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
25998 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26000 C...Weight with matrix element (if none known, use beta factor).
26001 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26003 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26004 ELSEIF(MMED.EQ.2) THEN
26005 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26006 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26007 ELSEIF(MMED.EQ.3) THEN
26008 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26012 IF(WTBE.LT.PYR(0)) GOTO 220
26016 C...Find suitable set of masses for initialization of 2 -> 2 processes.
26017 ELSEIF(MOFSH.EQ.3) THEN
26018 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26019 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26021 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26023 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26027 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26028 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26029 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26034 C...Evaluate importance of excluded tails of Breit-Wigners.
26035 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26036 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26040 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26044 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26045 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26047 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26048 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26049 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26050 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26052 C...Pick one particle to be the lighter (if improves efficiency).
26053 ELSEIF(MOFSH.EQ.4) THEN
26054 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26055 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26056 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26058 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26060 IF(MBW(I).EQ.0) GOTO 270
26062 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26064 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26066 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26067 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26068 IF(RBR.LT.0.8D0) THEN
26069 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26070 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26071 ELSEIF(RBR.LT.0.9D0) THEN
26072 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26073 ELSEIF(RBR.LT.1.5D0) THEN
26074 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26076 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26077 & (PMV**2-PML(I)**2))))
26080 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26081 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26082 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26083 NGEN(0,1)=NGEN(0,1)+1
26084 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26094 C...Give weight for selected mass distribution.
26097 IF(MBW(I).EQ.0) GOTO 280
26099 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26101 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26102 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26103 & (PMD(I)*PGD(I))**2)/PARU(1)
26107 FI0=(ATV-ATL(I))/PARU(1)
26108 FI1=PMV**2-PML(I)**2
26109 FI2=2D0*LOG(PMV/PML(I))
26110 FI3=1D0/PML(I)**2-1D0/PMV**2
26111 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26112 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
26113 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
26116 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
26118 VINT(80)=VINT(80)*FI0
26120 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26126 C***********************************************************************
26129 C...Handles the possibility of colour reconnection in W+W- events,
26130 C...Based on the main scenarios of the Sjostrand and Khoze study:
26131 C...I, II, II', intermediate and instantaneous; plus one model
26132 C...along the lines of the Gustafson and Hakkinen: GH.
26133 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
26134 C...is as if first resonance is W+ and second W-.
26136 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
26138 C...Double precision and integer declarations.
26139 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26140 IMPLICIT INTEGER(I-N)
26141 INTEGER PYK,PYCHGE,PYCOMP
26142 C...Parameter value; number of points in MC integration.
26143 PARAMETER (NPT=100)
26145 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
26146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26147 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26149 COMMON/PYINT1/MINT(400),VINT(400)
26150 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
26152 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
26153 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
26154 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
26155 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
26156 &TMC(20),IJOIN(100)
26158 C...Functions to give four-product and to do determinants.
26159 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)
26160 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
26161 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
26162 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
26164 C...Only allow fraction of recoupling for GH, intermediate and
26166 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
26167 IF(PYR(0).GT.PARP(120)) RETURN
26171 C...Common part for scenarios I, II, II', and GH.
26172 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
26173 &MSTP(115).EQ.5) THEN
26175 C...Read out frequently-used parameters.
26179 IF(ISUB.EQ.22) PMW=PMAS(23,1)
26181 IF(ISUB.EQ.22) PGW=PMAS(23,2)
26188 C...Find range of decay products of the W's.
26189 C...Background: the W's are stored in IW1 and IW2.
26190 C...Their direct decay products in NSD1+1 through NSD1+4.
26191 C...Products after shower (if any) in NSD1+5 through NAFT1
26192 C...for first W and in NAFT1+1 through N for the second.
26193 IF(NAFT1.GT.NSD1+4) THEN
26200 IF(N.GT.NAFT1) THEN
26208 C...Rearrange parton shower products along strings.
26210 CALL PYPREP(NSD1+1)
26211 IF(MINT(51).NE.0) RETURN
26213 C...Find partons pointing back to W+ and W-; store them with quark
26214 C...end of string first.
26220 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
26221 IF(IABS(K(I,2)).GE.22) GOTO 120
26222 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
26223 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
26233 IF(K(I,1).EQ.1) ISGP=0
26234 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
26235 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
26245 IF(K(I,1).EQ.1) ISGM=0
26249 C...Boost to W+W- rest frame (not strictly needed).
26251 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
26253 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26254 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26255 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26257 C...Select decay vertices of W+ and W-.
26258 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
26259 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
26260 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
26261 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
26264 XP(J)=TP*P(IW1,J)/P(IW1,4)
26265 XM(J)=TM*P(IW2,J)/P(IW2,4)
26268 C...Begin scenario I specifics.
26269 IF(MSTP(115).EQ.1) THEN
26271 C...Reconstruct velocity and direction of W+ string pieces.
26273 IF(K(INP(IIP),2).LT.0) GOTO 170
26276 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
26277 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
26281 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
26282 DIRP(IIP,J)=V1(J)-V2(J)
26284 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
26286 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
26288 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
26292 C...Reconstruct velocity and direction of W- string pieces.
26294 IF(K(INM(IIM),2).LT.0) GOTO 200
26297 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
26298 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
26302 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
26303 DIRM(IIM,J)=V1(J)-V2(J)
26305 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
26307 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
26309 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
26313 C...Loop over number of space-time points.
26318 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
26319 R=SQRT(-LOG(PYR(0)))
26321 X=BLOWR*RHAD*R*COS(PHI)
26322 Y=BLOWR*RHAD*R*SIN(PHI)
26323 R=SQRT(-LOG(PYR(0)))
26325 Z=BLOWR*RHAD*R*COS(PHI)
26326 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
26328 C...Reject impossible points. Weight for sample distribution.
26329 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
26330 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
26331 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
26333 C...Loop over W+ string pieces and find one with largest weight.
26341 IF(K(INP(IIP),2).LT.0) GOTO 220
26342 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
26343 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
26345 XB(J)=XD(J)+BEDG*BETP(IIP,J)
26347 XB(4)=BETP(IIP,4)*(XD(4)-BED)
26348 SR2=XB(1)**2+XB(2)**2+XB(3)**2
26349 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
26350 & DIRP(IIP,3)*XB(3))**2
26351 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
26353 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
26354 IF(WTP.GT.WTMAXP) THEN
26360 C...Loop over W- string pieces and find one with largest weight.
26368 IF(K(INM(IIM),2).LT.0) GOTO 240
26369 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
26370 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
26372 XB(J)=XD(J)+BEDG*BETM(IIM,J)
26374 XB(4)=BETM(IIM,4)*(XD(4)-BED)
26375 SR2=XB(1)**2+XB(2)**2+XB(3)**2
26376 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
26377 & DIRM(IIM,3)*XB(3))**2
26378 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
26380 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
26381 IF(WTM.GT.WTMAXM) THEN
26387 C...Result of integration.
26389 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
26390 WT=WTMAXP*WTMAXM/WTSMP
26398 RES=BLOWR**3*BLOWT*SUM/NPT
26400 C...Decide whether to reconnect and, if so, where.
26402 PREC=1D0-EXP(-FACT*RES)
26403 IF(PREC.GT.PYR(0)) THEN
26408 IF(RSUM.LE.0D0) GOTO 270
26414 C...Begin scenario II and II' specifics.
26415 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
26417 C...Loop through all string pieces, one from W+ and one from W-.
26421 IF(K(INP(IIP),2).LT.0) GOTO 340
26425 IF(K(INM(IIM),2).LT.0) GOTO 330
26429 C...Find endpoint velocity vectors.
26431 V1P(J)=P(I1P,J)/P(I1P,4)
26432 V2P(J)=P(I2P,J)/P(I2P,4)
26433 V1M(J)=P(I1M,J)/P(I1M,4)
26434 V2M(J)=P(I2M,J)/P(I2M,4)
26437 C...Define q matrix and find t.
26439 Q(1,J)=V2P(J)-V1P(J)
26440 Q(2,J)=-(V2M(J)-V1M(J))
26441 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
26442 Q(4,J)=V1P(J)-V1M(J)
26444 T=-DETER(1,2,3)/DETER(1,2,4)
26446 C...Find alpha and beta; i.e. coordinates of crossing point.
26449 S13=Q(3,1)+Q(4,1)*T
26452 S23=Q(3,2)+Q(4,2)*T
26453 DEN=S11*S22-S12*S21
26454 ALP=(S12*S23-S22*S13)/DEN
26455 BET=(S21*S13-S11*S23)/DEN
26457 C...Check if solution acceptable.
26459 IF(T.LT.GTMAX) IANSW=0
26460 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
26461 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
26463 C...Find point of crossing and check that not inconsistent.
26465 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
26466 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
26468 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
26469 & (XPP(3)-XMM(3))**2
26470 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
26471 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
26472 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
26474 C...Find string eigentimes at crossing.
26475 IF(IANSW.EQ.1) THEN
26476 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
26477 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
26478 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
26479 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
26485 C...Order crossings by time. End loop over crossings.
26486 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
26488 DO 310 I1=NCROSS,1,-1
26489 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
26509 C...Loop over crossings; find first (if any) acceptable one.
26511 IF(NCROSS.GE.1) THEN
26513 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
26514 IF(PNFRAG.GT.PYR(0)) THEN
26515 C...Scenario II: only compare with fragmentation time.
26516 IF(MSTP(115).EQ.2) THEN
26521 C...Scenario II': also require that string length decreases.
26529 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
26530 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
26531 IF(ELNEW.LT.ELOLD) THEN
26543 C...Begin scenario GH specifics.
26544 ELSEIF(MSTP(115).EQ.5) THEN
26546 C...Loop through all string pieces, one from W+ and one from W-.
26550 IF(K(INP(IIP),2).LT.0) GOTO 380
26554 IF(K(INM(IIM),2).LT.0) GOTO 370
26558 C...Look for largest decrease of (exponent of) Lambda measure.
26559 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
26560 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
26561 ELDIF=ELNEW/MAX(1D-10,ELOLD)
26562 IF(ELDIF.LT.ELMIN) THEN
26574 C...Common for scenarios I, II, II' and GH: reconnect strings.
26578 DO 390 IS=1,NNP+NNM
26582 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
26584 ELSEIF(IS.LE.IIP+NNM) THEN
26585 I=INM(IS-IIP-NNM+IIM)
26590 IF(K(I,2).LT.0) THEN
26591 CALL PYJOIN(NJOIN,IJOIN)
26596 C...Restore original event record if no reconnection.
26598 DO 400 I=NSD1+1,NOLD
26599 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
26600 K(I,4)=MOD(K(I,4),MSTU(5)**2)
26601 K(I,5)=MOD(K(I,5),MSTU(5)**2)
26610 C...Boost back system.
26611 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
26612 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
26613 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
26614 & BEWW(1),BEWW(2),BEWW(3))
26616 C...Common part for intermediate and instantaneous scenarios.
26617 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
26620 C...Remove old shower products and reset showering ones.
26622 DO 420 I=NSD1+1,NSD1+4
26624 K(I,4)=MOD(K(I,4),MSTU(5)**2)
26625 K(I,5)=MOD(K(I,5),MSTU(5)**2)
26628 C...Identify quark-antiquark pairs.
26632 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
26635 C...Reconnect strings.
26638 CALL PYJOIN(2,IJOIN)
26641 CALL PYJOIN(2,IJOIN)
26643 C...Do new parton showers in intermediate scenario.
26644 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
26647 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
26648 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
26651 C...Do new parton showers in instantaneous scenario.
26652 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
26653 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
26654 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
26655 PPM=SQRT(MAX(0D0,PPM2))
26656 CALL PYSHOW(IQ1,IQ4,PPM)
26657 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
26658 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
26659 PPM=SQRT(MAX(0D0,PPM2))
26660 CALL PYSHOW(IQ3,IQ2,PPM)
26667 C***********************************************************************
26670 C...Checks generated variables against pre-set kinematical limits;
26671 C...also calculates limits on variables used in generation.
26673 SUBROUTINE PYKLIM(ILIM)
26675 C...Double precision and integer declarations.
26676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26677 IMPLICIT INTEGER(I-N)
26678 INTEGER PYK,PYCHGE,PYCOMP
26680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
26681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26683 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26684 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26685 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26686 COMMON/PYINT1/MINT(400),VINT(400)
26687 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26688 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
26691 C...Common kinematical expressions.
26695 IF(ISUB.EQ.96) GOTO 100
26699 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
26700 CKIN09=MAX(CKIN(9),CKIN(13))
26701 CKIN10=MIN(CKIN(10),CKIN(14))
26702 CKIN11=MAX(CKIN(11),CKIN(15))
26703 CKIN12=MIN(CKIN(12),CKIN(16))
26705 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
26706 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
26707 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
26708 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
26713 RM3=SQM3/(TAU*VINT(2))
26714 RM4=SQM4/(TAU*VINT(2))
26715 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
26718 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
26719 &PTHMIN=MAX(CKIN(3),CKIN(5))
26722 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
26723 C...pre-set kinematical limits.
26728 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
26729 X1=SQRT(TAUE)*EXP(YST)
26730 X2=SQRT(TAUE)*EXP(-YST)
26732 IF(MINT(47).NE.1) THEN
26733 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
26734 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
26735 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
26736 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
26738 IF(MINT(45).NE.1) THEN
26739 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
26741 IF(MINT(46).NE.1) THEN
26742 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
26744 IF(MINT(45).EQ.2) THEN
26745 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
26747 IF(MINT(46).EQ.2) THEN
26748 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
26750 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
26751 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
26752 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
26753 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
26754 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
26755 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
26756 Y3=YST+0.5D0*LOG(EXPY3)
26757 Y4=YST+0.5D0*LOG(EXPY4)
26762 STH=SQRT(MAX(0D0,1D0-CTH**2))
26763 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
26764 & CTH)**2-4D0*RM3))
26765 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
26766 & CTH)**2-4D0*RM4))
26767 IF(STH.GE.1D-10) THEN
26768 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
26770 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
26772 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
26773 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
26774 ETALAR=MAX(ETA3,ETA4)
26775 ETASMA=MIN(ETA3,ETA4)
26777 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
26778 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
26779 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
26780 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
26782 RPTS=4D0*VINT(71)**2/SH
26783 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
26784 RM34=MAX(1D-20,2D0*RM3*RM4)
26785 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
26786 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
26787 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
26788 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
26789 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
26790 IF(PTH.LT.PTHMIN) MINT(51)=1
26791 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
26792 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
26793 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
26794 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
26795 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
26796 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
26797 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
26798 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
26799 IF(THA.LT.CKIN(35)) MINT(51)=1
26800 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
26801 IF(UHA.LT.CKIN(37)) MINT(51)=1
26802 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
26804 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
26805 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
26806 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
26809 C...Additional cuts on W2 (approximately) in DIS.
26810 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
26812 IF(IABS(MINT(12)).LT.20) XBJ=X1
26814 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
26815 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
26816 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
26819 ELSEIF(ILIM.EQ.1) THEN
26820 C...Calculate limits on tau
26821 C...0) due to definition
26824 C...1) due to limits on subsystem mass
26825 TAUMN1=CKIN(1)**2/VINT(2)
26827 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
26828 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
26829 TM3=SQRT(SQM3+PTHMIN**2)
26830 TM4=SQRT(SQM4+PTHMIN**2)
26832 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
26833 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
26835 C...3) due to limits on pT-hat and cos(theta-hat)
26836 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
26837 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
26839 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
26840 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
26841 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
26843 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
26844 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
26845 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
26846 C...4) due to limits on x1 and x2
26847 TAUMN4=CKIN(21)*CKIN(23)
26848 TAUMX4=CKIN(22)*CKIN(24)
26849 C...5) due to limits on xF
26851 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
26852 C...6) due to limits on that and uhat
26853 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
26855 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
26856 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
26858 C...Net effect of all separate limits.
26859 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
26860 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
26861 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
26864 ELSEIF(MINT(47).EQ.5) THEN
26865 VINT(31)=MIN(VINT(31),1D0-2D-10)
26866 ELSEIF(MINT(47).GE.6) THEN
26867 VINT(31)=MIN(VINT(31),1D0-1D-10)
26869 IF(VINT(31).LE.VINT(11)) MINT(51)=1
26871 ELSEIF(ILIM.EQ.2) THEN
26872 C...Calculate limits on y*
26874 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
26876 C...0) due to kinematics
26879 C...1) due to explicit limits
26882 C...2) due to limits on x1
26883 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
26884 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
26885 C...3) due to limits on x2
26886 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
26887 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
26888 C...4) due to limits on xF
26889 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
26890 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
26891 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
26892 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
26893 C...5) due to simultaneous limits on y-large and y-small
26894 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
26895 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
26896 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
26897 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
26898 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
26899 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
26900 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
26902 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
26903 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
26904 RZMX=BE34*MIN(CKIN(28),CTHLIM)
26905 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
26906 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
26907 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
26908 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
26909 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
26910 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
26912 C...Net effect of all separate limits.
26913 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
26914 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
26915 IF(MINT(47).EQ.1) THEN
26918 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
26919 VINT(12)=(1D0-1D-9)*YSTMX0
26920 VINT(32)=(1D0+1D-9)*YSTMX0
26921 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
26922 VINT(12)=-(1D0+1D-9)*YSTMX0
26923 VINT(32)=-(1D0-1D-9)*YSTMX0
26924 ELSEIF(MINT(47).EQ.5) THEN
26925 YSTEE=LOG((1D0-1D-10)/TAURT)
26926 VINT(12)=MAX(VINT(12),-YSTEE)
26927 VINT(32)=MIN(VINT(32),YSTEE)
26929 IF(VINT(32).LE.VINT(12)) MINT(51)=1
26931 ELSEIF(ILIM.EQ.3) THEN
26932 C...Calculate limits on cos(theta-hat)
26934 C...0) due to definition
26939 C...1) due to explicit limits
26940 CTNMN1=MIN(0D0,CKIN(27))
26941 CTNMX1=MIN(0D0,CKIN(28))
26942 CTPMN1=MAX(0D0,CKIN(27))
26943 CTPMX1=MAX(0D0,CKIN(28))
26944 C...2) due to limits on pT-hat
26945 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
26949 IF(CKIN(4).GE.0D0) THEN
26950 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
26951 & (BE34**2*TAU*VINT(2))))
26954 C...3) due to limits on y-large and y-small
26955 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
26956 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
26957 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
26958 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
26959 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
26960 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
26961 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
26962 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
26963 C...4) due to limits on that
26969 IF(CKIN(35).GT.0D0) THEN
26970 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
26971 IF(CTLIM.GT.0D0) THEN
26978 IF(CKIN(36).GT.0D0) THEN
26979 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
26980 IF(CTLIM.LT.0D0) THEN
26987 C...5) due to limits on uhat
26992 IF(CKIN(37).GT.0D0) THEN
26993 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
26994 IF(CTLIM.LT.0D0) THEN
27001 IF(CKIN(38).GT.0D0) THEN
27002 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27003 IF(CTLIM.GT.0D0) THEN
27011 C...Net effect of all separate limits.
27012 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27013 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27014 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27015 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27016 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27018 ELSEIF(ILIM.EQ.4) THEN
27019 C...Calculate limits on tau'
27020 C...0) due to kinematics
27022 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27023 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27024 TAPMN0=(SQRT(TAU)+PQRAT)**2
27027 C...1) due to explicit limits
27028 TAPMN1=CKIN(31)**2/VINT(2)
27030 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27032 C...Net effect of all separate limits.
27033 VINT(16)=MAX(TAPMN0,TAPMN1)
27034 VINT(36)=MIN(TAPMX0,TAPMX1)
27035 IF(MINT(47).EQ.1) THEN
27038 ELSEIF(MINT(47).EQ.5) THEN
27039 VINT(36)=MIN(VINT(36),1D0-2D-10)
27040 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27041 VINT(36)=MIN(VINT(36),1D0-1D-10)
27043 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27048 C...Special case for low-pT and multiple interactions:
27049 C...effective kinematical limits for tau, y*, cos(theta-hat).
27050 100 IF(ILIM.EQ.0) THEN
27051 ELSEIF(ILIM.EQ.1) THEN
27052 IF(MSTP(82).LE.1) THEN
27053 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27056 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27059 ELSEIF(ILIM.EQ.2) THEN
27060 VINT(12)=0.5D0*LOG(VINT(21))
27062 ELSEIF(ILIM.EQ.3) THEN
27063 IF(MSTP(82).LE.1) THEN
27064 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27065 & (VINT(21)*VINT(2))
27067 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27068 & (VINT(21)*VINT(2))
27070 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27079 C*********************************************************************
27082 C...Maps a uniform distribution into a distribution of a kinematical
27083 C...variable according to one of the possibilities allowed. It is
27084 C...assumed that kinematical limits have been set by a PYKLIM call.
27086 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27088 C...Double precision and integer declarations.
27089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27090 IMPLICIT INTEGER(I-N)
27091 INTEGER PYK,PYCHGE,PYCOMP
27093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27094 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27095 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27096 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27097 COMMON/PYINT1/MINT(400),VINT(400)
27098 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27099 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
27101 C...Convert VVAR to tau variable.
27107 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
27110 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
27114 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27116 ELSEIF(MVAR.EQ.1) THEN
27117 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
27118 ELSEIF(MVAR.EQ.2) THEN
27119 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
27120 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
27121 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
27122 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
27123 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
27124 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
27125 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
27126 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
27127 ELSEIF(MINT(47).EQ.5) THEN
27128 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
27129 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
27130 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27132 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
27133 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
27134 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27136 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
27138 C...Convert VVAR to y* variable.
27139 ELSEIF(IVAR.EQ.2) THEN
27143 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27144 IF(MINT(47).EQ.1) THEN
27146 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27147 YST=-0.5D0*LOG(TAUE)
27148 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27149 YST=0.5D0*LOG(TAUE)
27150 ELSEIF(MVAR.EQ.1) THEN
27151 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
27152 ELSEIF(MVAR.EQ.2) THEN
27153 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
27154 ELSEIF(MVAR.EQ.3) THEN
27155 AUPP=ATAN(EXP(YSTMAX))
27156 ALOW=ATAN(EXP(YSTMIN))
27157 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
27158 ELSEIF(MVAR.EQ.4) THEN
27159 YST0=-0.5D0*LOG(TAUE)
27160 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
27161 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
27162 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
27164 YST0=-0.5D0*LOG(TAUE)
27165 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
27166 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
27167 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
27169 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
27171 C...Convert VVAR to cos(theta-hat) variable.
27172 ELSEIF(IVAR.EQ.3) THEN
27173 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
27175 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27176 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27184 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27185 VCTN=VVAR*(ANEG+APOS)/ANEG
27186 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
27188 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27189 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
27191 ELSEIF(MVAR.EQ.2) THEN
27192 RMNMIN=MAX(RM34,RSQM-CTNMIN)
27193 RMNMAX=MAX(RM34,RSQM-CTNMAX)
27194 RMPMIN=MAX(RM34,RSQM-CTPMIN)
27195 RMPMAX=MAX(RM34,RSQM-CTPMAX)
27196 ANEG=LOG(RMNMIN/RMNMAX)
27197 APOS=LOG(RMPMIN/RMPMAX)
27198 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27199 VCTN=VVAR*(ANEG+APOS)/ANEG
27200 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
27202 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27203 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
27205 ELSEIF(MVAR.EQ.3) THEN
27206 RMNMIN=MAX(RM34,RSQM+CTNMIN)
27207 RMNMAX=MAX(RM34,RSQM+CTNMAX)
27208 RMPMIN=MAX(RM34,RSQM+CTPMIN)
27209 RMPMAX=MAX(RM34,RSQM+CTPMAX)
27210 ANEG=LOG(RMNMAX/RMNMIN)
27211 APOS=LOG(RMPMAX/RMPMIN)
27212 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27213 VCTN=VVAR*(ANEG+APOS)/ANEG
27214 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
27216 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27217 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
27219 ELSEIF(MVAR.EQ.4) THEN
27220 RMNMIN=MAX(RM34,RSQM-CTNMIN)
27221 RMNMAX=MAX(RM34,RSQM-CTNMAX)
27222 RMPMIN=MAX(RM34,RSQM-CTPMIN)
27223 RMPMAX=MAX(RM34,RSQM-CTPMAX)
27224 ANEG=1D0/RMNMAX-1D0/RMNMIN
27225 APOS=1D0/RMPMAX-1D0/RMPMIN
27226 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27227 VCTN=VVAR*(ANEG+APOS)/ANEG
27228 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
27230 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27231 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
27233 ELSEIF(MVAR.EQ.5) THEN
27234 RMNMIN=MAX(RM34,RSQM+CTNMIN)
27235 RMNMAX=MAX(RM34,RSQM+CTNMAX)
27236 RMPMIN=MAX(RM34,RSQM+CTPMIN)
27237 RMPMAX=MAX(RM34,RSQM+CTPMAX)
27238 ANEG=1D0/RMNMIN-1D0/RMNMAX
27239 APOS=1D0/RMPMIN-1D0/RMPMAX
27240 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27241 VCTN=VVAR*(ANEG+APOS)/ANEG
27242 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
27244 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27245 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
27248 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
27249 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
27252 C...Convert VVAR to tau' variable.
27253 ELSEIF(IVAR.EQ.4) THEN
27257 IF(MINT(47).EQ.1) THEN
27259 ELSEIF(MVAR.EQ.1) THEN
27260 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
27261 ELSEIF(MVAR.EQ.2) THEN
27262 AUPP=(1D0-TAU/TAUPMX)**4
27263 ALOW=(1D0-TAU/TAUPMN)**4
27264 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
27265 ELSEIF(MINT(47).EQ.5) THEN
27266 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
27267 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
27268 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27270 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
27271 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
27272 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27274 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
27276 C...Selection of extra variables needed in 2 -> 3 process:
27277 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
27278 C...Since no options are available, the functions of PYKLIM
27279 C...and PYKMAP are joint for these choices.
27280 ELSEIF(IVAR.EQ.5) THEN
27282 C...Read out total energy and particle masses.
27285 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
27286 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
27288 SHP=VINT(26)*VINT(2)
27292 PM3=SQRT(VINT(21))*VINT(1)
27293 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
27300 C...Specify coefficients of pT choice; upper and lower limits.
27301 IF(MPTPK.EQ.1) THEN
27309 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
27311 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
27313 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
27315 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
27318 C...Select transverse momenta according to
27319 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
27322 IF(HMX.LT.1.0001D0*HMN) THEN
27328 IF(RPT.LT.HWT1) THEN
27329 PTS1=PTSMN1+PYR(0)*HDE
27330 ELSEIF(RPT.LT.HWT1+HWT2) THEN
27331 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
27333 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
27335 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
27336 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
27339 IF(HMX.LT.1.0001D0*HMN) THEN
27345 IF(RPT.LT.HWT1) THEN
27346 PTS2=PTSMN2+PYR(0)*HDE
27347 ELSEIF(RPT.LT.HWT1+HWT2) THEN
27348 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
27350 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
27352 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
27353 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
27355 C...Select azimuthal angles and check pT choice.
27356 PHI1=PARU(2)*PYR(0)
27357 PHI2=PARU(2)*PYR(0)
27359 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
27360 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
27361 & CKIN(56)**2)) THEN
27366 C...Calculate transverse masses and check phase space not closed.
27373 PM12=(PMT1+PMT2)**2
27374 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
27379 C...Select rapidity for particle 3 and check phase space not closed.
27380 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
27381 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
27382 IF(Y3MAX.LT.1D-6) THEN
27386 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
27390 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
27393 PMS12=PE12**2-PZ12**2
27394 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
27395 IF(SQL12.LT.1D-6*SHP) THEN
27399 PMM1=PMS12+PMS1-PMS2
27400 PMM2=PMS12+PMS2-PMS1
27401 TFAC=-SHPR/(2D0*PMS12)
27402 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
27403 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
27404 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
27405 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
27407 C...Construct relative mirror weights and make choice.
27408 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27412 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
27413 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
27415 WTP=WTPU/(WTPU+WTNU)
27416 WTN=WTNU/(WTPU+WTNU)
27418 IF(WTN.GT.PYR(0)) EPS=-1D0
27420 C...Store result of variable choice and associated weights.
27430 IF(EPS.GT.0D0) THEN
27439 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
27440 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
27441 VINT(219)=0.5D0*(PMS12-PTS3)
27448 C***********************************************************************
27451 C...Differential matrix elements for all included subprocesses
27452 C...Note that what is coded is (disregarding the COMFAC factor)
27453 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
27454 C...when d(sigma-hat) is given in the zero-width limit, the delta
27455 C...function in tau is replaced by a (modified) Breit-Wigner:
27456 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
27457 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
27458 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
27459 C...i.e., dimensionless quantities
27460 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
27461 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
27462 C...(2pi)^4 delta^4(P - sum p_i)
27463 C...COMFAC contains the factor pi/s (or equivalent) and
27464 C...the conversion factor from GeV^-2 to mb
27466 SUBROUTINE PYSIGH(NCHN,SIGS)
27468 C...Double precision and integer declarations
27469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27470 IMPLICIT INTEGER(I-N)
27471 INTEGER PYK,PYCHGE,PYCOMP
27472 C...Parameter statement to help give large particle numbers.
27473 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
27474 &KEXCIT=4000000,KDIMEN=5000000)
27476 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27477 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27478 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27479 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27480 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27481 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27482 COMMON/PYINT1/MINT(400),VINT(400)
27483 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27484 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
27485 COMMON/PYINT4/MWID(500),WIDS(500,5)
27486 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27487 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
27488 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27489 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27490 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
27491 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
27492 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
27493 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
27494 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
27495 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
27496 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27497 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
27498 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
27499 C...Local arrays and complex variables
27500 DIMENSION XPQ(-25:25)
27502 C...Map of processes onto which routine to call
27503 C...in order to evaluate cross section:
27504 C...0 = not implemented;
27505 C...1 = standard QCD (including photons);
27506 C...2 = heavy flavours;
27508 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
27510 C...6 = Technicolor;
27511 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
27512 DIMENSION MAPPR(500)
27513 DATA (MAPPR(I),I=1,180)/
27514 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
27515 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
27516 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
27517 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
27518 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
27519 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
27520 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
27521 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
27522 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27523 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
27524 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
27525 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
27526 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
27527 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
27528 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
27529 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
27530 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
27531 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
27532 DATA (MAPPR(I),I=181,500)/
27533 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
27534 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
27536 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
27538 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
27539 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
27540 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
27541 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
27542 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
27543 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
27545 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
27546 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27548 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
27549 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27552 C...Reset number of channels and cross-section
27556 C...Read process to consider.
27561 C...Read kinematical variables and limits
27579 C...Derive kinematical quantities
27581 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27582 X(1)=SQRT(TAUE)*EXP(YST)
27583 X(2)=SQRT(TAUE)*EXP(-YST)
27584 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
27585 IF(X(1).GT.1D0-1D-7) RETURN
27586 ELSEIF(MINT(45).EQ.3) THEN
27587 X(1)=MIN(1D0-1.1D-10,X(1))
27589 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
27590 IF(X(2).GT.1D0-1D-7) RETURN
27591 ELSEIF(MINT(46).EQ.3) THEN
27592 X(2)=MIN(1D0-1.1D-10,X(2))
27594 SH=MAX(1D0,TAU*VINT(2))
27599 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27600 RPTS=4D0*VINT(71)**2/SH
27601 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27602 RM34=MAX(1D-20,2D0*RM3*RM4)
27604 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
27605 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
27606 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27607 IF(ISTSB.EQ.0) THEN
27609 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27610 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
27612 C...Kinematics with incoming masses tricky: now depends on how
27613 C...subprocess has been set up w.r.t. order of incoming partons.
27615 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
27617 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
27618 IF(ISUB.EQ.35) THEN
27622 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27623 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
27624 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
27626 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
27628 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
27635 C...Choice of Q2 scale for hard process (e.g. alpha_s).
27636 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
27638 ELSEIF(ISTSB.EQ.8) THEN
27639 IF(MINT(107).EQ.4) Q2=VINT(307)
27640 IF(MINT(108).EQ.4) Q2=VINT(308)
27641 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
27643 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
27645 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
27646 IF(MSTP(32).EQ.1) THEN
27647 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
27648 ELSEIF(MSTP(32).EQ.2) THEN
27649 Q2=SQPTH+0.5D0*(SQM3+SQM4)
27650 ELSEIF(MSTP(32).EQ.3) THEN
27652 ELSEIF(MSTP(32).EQ.4) THEN
27654 ELSEIF(MSTP(32).EQ.5) THEN
27656 ELSEIF(MSTP(32).EQ.6) THEN
27658 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
27660 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
27661 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
27662 & (SQPTH+0.5D0*(SQM3+SQM4))
27663 ELSEIF(MSTP(32).EQ.7) THEN
27664 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
27665 ELSEIF(MSTP(32).EQ.8) THEN
27666 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
27667 ELSEIF(MSTP(32).EQ.9) THEN
27668 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
27669 ELSEIF(MSTP(32).EQ.10) THEN
27672 ELSEIF(MSTP(32).EQ.11) THEN
27673 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
27674 ELSEIF(MSTP(32).EQ.12) THEN
27677 ELSEIF(MSTP(32).EQ.13) THEN
27680 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
27681 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
27682 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
27685 C...Choice of Q2 scale for parton densities.
27688 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
27689 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
27692 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27694 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
27695 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
27696 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
27697 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
27698 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
27699 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
27700 IF(MSTP(39).EQ.2) Q2SF=
27701 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
27702 IF(MSTP(39).EQ.3) Q2SF=SH
27703 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
27704 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
27706 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
27707 IF(MSTP(39).EQ.7) Q2SF=
27708 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
27709 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
27713 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
27717 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
27718 IF(MSTP(69).GE.2) Q2SF=VINT(2)
27720 C...Identify to which class(es) subprocess belongs
27724 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.102.OR.
27725 & ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144.OR.
27726 & ISUBSV.EQ.152.OR.ISUBSV.EQ.157) ISMECR=1
27727 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
27728 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
27729 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
27730 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
27731 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
27732 IF (ISTSB.EQ.9) ISQCD=1
27733 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
27734 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
27735 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
27736 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
27737 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
27738 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
27739 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
27740 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
27741 C...WBF is special case of ISJETS
27742 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
27743 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
27744 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
27745 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
27746 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
27747 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
27748 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
27749 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
27750 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
27751 C...Some processes with photons also belong here.
27752 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
27753 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
27754 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
27755 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
27756 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
27757 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
27759 C...Choice of Q2 scale for parton-shower activity.
27760 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
27761 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
27763 IF(MINT(43).EQ.3) XBJ=X(1)
27764 IF(MSTP(22).EQ.1) THEN
27766 ELSEIF(MSTP(22).EQ.2) THEN
27767 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
27768 ELSEIF(MSTP(22).EQ.3) THEN
27769 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
27771 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
27774 C...For multiple interactions, start from scale defined above
27775 C...For all other QCD or "+jets"-type events, start shower from pThard.
27776 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
27777 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
27778 C...Max shower scale = s for ME corrected processes.
27779 C...(pT-ordering: max pT2 is s/4)
27781 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
27782 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
27783 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
27784 C...(pT-ordering: max pT2 is s/4)
27786 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
27788 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
27790 C...Elastic and diffractive events not associated with scales so set 0.
27791 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
27796 C...Store derived kinematical quantities
27803 IF(ISTSB.NE.8) VINT(48)=SQPTH
27804 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
27805 VINT(50)=TAUP*VINT(2)
27806 VINT(49)=SQRT(MAX(0D0,VINT(50)))
27810 VINT(53)=SQRT(Q2SF)
27812 VINT(55)=SQRT(Q2PS)
27814 C...Set starting scale for multiple interactions
27815 IF (ISUBSV.EQ.95) THEN
27817 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
27818 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
27819 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
27820 & ISUBSV.NE.96)) THEN
27821 C...All accessible phase space allowed.
27822 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
27824 C...Scale of hard process sets limit.
27825 C...2 -> 1. Limit is tau = x1*x2.
27826 C...2 -> 2. Limit is XT2 for hard process + FS masses.
27827 C...2 -> n > 2. Limit is tau' = tau of outer process.
27829 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
27831 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
27832 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
27834 VINT(62)=0.25D0*XT2GMX*VINT(2)
27835 VINT(61)=SQRT(MAX(0D0,VINT(62)))
27837 C...Calculate parton distributions
27838 IF(ISTSB.LE.0) GOTO 160
27839 IF(MINT(47).GE.2) THEN
27840 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
27842 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
27843 IF(ISUB.EQ.99) THEN
27844 IF(MINT(140+I).EQ.0) THEN
27845 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
27847 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
27852 MINT(105)=MINT(102+I)
27853 MINT(109)=MINT(106+I)
27854 VINT(120)=VINT(2+I)
27855 IF(MSTP(57).LE.1) THEN
27856 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
27858 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
27860 C...Safety margin against heavy flavour very close to threshold,
27861 C...e.g. caused by mismatch in c and b masses.
27862 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
27866 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
27871 XSFX(I,KFL)=XPQ(KFL)
27876 C...Calculate alpha_em, alpha_strong and K-factor
27879 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
27880 &1D0-(PMAS(24,1)/PMAS(23,1))**2
27882 XWC=1D0/(16D0*XW*XW1)
27884 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
27885 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
27888 IF(MSTP(33).EQ.1) THEN
27890 ELSEIF(MSTP(33).EQ.2) THEN
27892 FACA=PARP(32)/PARP(31)
27893 ELSEIF(MSTP(33).EQ.3) THEN
27895 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
27896 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
27903 C...Set flags for allowed reacting partons/leptons
27908 IF(MINT(44+I).EQ.1) THEN
27909 KFAC(I,MINT(10+I))=1
27910 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
27911 KFAC(I,MINT(10+I))=1
27917 KFAC(I,J)=KFIN(I,J)
27918 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
27919 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
27924 C...Lower and upper limit for fermion flavour loops
27930 IF(KFAC(1,-J).EQ.1) MMIN1=-J
27931 IF(KFAC(1,J).EQ.1) MMAX1=J
27932 IF(KFAC(2,-J).EQ.1) MMIN2=-J
27933 IF(KFAC(2,J).EQ.1) MMAX2=J
27935 MMINA=MIN(MMIN1,MMIN2)
27936 MMAXA=MAX(MMAX1,MMAX2)
27938 C...Common resonance mass and width combinations
27941 GMMZ=PMAS(23,1)*PMAS(23,2)
27942 GMMW=PMAS(24,1)*PMAS(24,2)
27944 C...Polarization factors...implemented so far for W+W-(25)
27945 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
27946 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
27947 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
27948 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
27950 C...Phase space integral in tau
27951 COMFAC=PARU(1)*PARU(5)/VINT(2)
27952 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
27953 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
27954 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
27955 ATAU1=LOG(TAUMAX/TAUMIN)
27956 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
27957 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
27958 IF(MINT(72).GE.1) THEN
27961 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
27963 IF(ATAUD.GT.1D-10) H1=H1+
27964 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
27965 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
27967 IF(ATAUD.GT.1D-10) H1=H1+
27968 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
27970 IF(MINT(72).EQ.2) THEN
27973 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
27975 IF(ATAUD.GT.1D-10) H1=H1+
27976 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
27977 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
27979 IF(ATAUD.GT.1D-10) H1=H1+
27980 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
27982 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
27983 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
27984 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
27985 & MAX(2D-10,1D0-TAU)
27986 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
27987 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
27988 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
27989 & MAX(1D-10,1D0-TAU)
27991 COMFAC=COMFAC*ATAU1/(TAU*H1)
27994 C...Phase space integral in y*
27995 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
27997 AYST0=YSTMAX-YSTMIN
27998 IF(AYST0.LT.1D-10) THEN
28001 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28003 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28004 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28005 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28006 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28007 IF(MINT(45).EQ.3) THEN
28008 YST0=-0.5D0*LOG(TAUE)
28009 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28010 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28011 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28012 & MAX(1D-10,1D0-EXP(YST-YST0))
28014 IF(MINT(46).EQ.3) THEN
28015 YST0=-0.5D0*LOG(TAUE)
28016 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28017 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28018 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28019 & MAX(1D-10,1D0-EXP(-YST-YST0))
28021 COMFAC=COMFAC*AYST0/H2
28025 C...2 -> 1 processes: reduction in angular part of phase space integral
28026 C...for case of decaying resonance
28027 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28028 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28029 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28030 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28031 & KFPR(ISUB,1).EQ.39) THEN
28032 COMFAC=COMFAC*0.5D0*ACTH0
28034 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28035 & CTPMAX**3-CTPMIN**3)
28039 C...2 -> 2 processes: angular part of phase space integral
28040 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28041 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28042 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28043 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28044 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28045 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28046 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28047 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28048 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28049 H3=COEF(ISUBSV,13)+
28050 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28051 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28052 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28053 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28054 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28056 C...2 -> 2 processes: take into account final state Breit-Wigners
28057 COMFAC=COMFAC*VINT(80)
28060 C...2 -> 3, 4 processes: phace space integral in tau'
28061 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28062 ATAUP1=LOG(TAUPMX/TAUPMN)
28063 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28064 H4=COEF(ISUBSV,18)+
28065 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28066 IF(MINT(47).EQ.5) THEN
28067 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28068 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28069 ELSEIF(MINT(47).GE.6) THEN
28070 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28071 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28073 COMFAC=COMFAC*ATAUP1/H4
28076 C...2 -> 3, 4 processes: effective W/Z parton distributions
28077 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28078 IF(1D0-TAU/TAUP.GT.1D-4) THEN
28079 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
28081 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
28086 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
28087 IF(ISTSB.EQ.5) THEN
28088 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
28089 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
28092 C...Phase space integral for low-pT and multiple interactions
28093 IF(ISTSB.EQ.9) THEN
28094 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
28095 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
28096 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
28097 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
28098 COMFAC=COMFAC*ATAU1/H1
28099 AYST0=YSTMAX-YSTMIN
28100 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28101 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28102 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28103 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28104 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28105 COMFAC=COMFAC*AYST0/H2
28106 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
28107 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
28108 C...introduced to make cross-section finite for xT2 -> 0
28109 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
28113 C...Real gamma + gamma: include factor 2 when different nature
28114 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
28115 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
28117 C...Extra factors to include the effects of
28118 C...longitudinal resolved photons (but not direct or DIS ones).
28120 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
28121 & MINT(106+ISDE).LE.3) THEN
28124 IF(MSTP(16).EQ.0) THEN
28125 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
28126 & XY=VINT(304+ISDE)
28128 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
28129 & XY=VINT(308+ISDE)
28131 Q2GA=VINT(306+ISDE)
28132 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
28133 & Q2GA.GT.0D0) THEN
28135 IF(MSTP(17).EQ.1) THEN
28136 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
28137 ELSEIF(MSTP(17).EQ.2) THEN
28138 REDUCE=4D0*Q2GA/(Q2+Q2GA)
28139 ELSEIF(MSTP(17).EQ.3) THEN
28140 PMVIRT=PMAS(PYCOMP(113),1)
28141 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28142 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
28143 PMVIRT=PMAS(PYCOMP(113),1)
28144 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
28145 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
28146 PMVIRT=PMAS(PYCOMP(113),1)
28147 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
28148 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
28149 PMVSMN=4D0*PARP(15)**2
28150 PMVSMX=4D0*VINT(154)**2
28151 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
28152 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
28153 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
28154 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
28155 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
28156 PMVIRT=PMAS(PYCOMP(113),1)
28157 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28158 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
28159 PMVIRT=PMAS(PYCOMP(113),1)
28160 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28161 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
28162 PMVSMN=4D0*PARP(15)**2
28163 PMVSMX=4D0*VINT(154)**2
28164 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
28165 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
28166 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
28169 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
28170 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
28171 & (1D0-2D0*BEAMAS**2/Q2GA))
28172 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
28177 COMFAC=COMFAC*VINT(314+ISDE)
28180 C...Evaluate cross sections - done in separate routines by kind
28181 C...of physics, to keep PYSIGH of sensible size.
28183 C...Standard QCD (including photons).
28184 CALL PYSGQC(NCHN,SIGS)
28185 ELSEIF(MAP.EQ.2) THEN
28186 C...Heavy flavours.
28187 CALL PYSGHF(NCHN,SIGS)
28188 ELSEIF(MAP.EQ.3) THEN
28190 CALL PYSGWZ(NCHN,SIGS)
28191 ELSEIF(MAP.EQ.4) THEN
28192 C...Higgs (2 doublets; including longitudinal W/Z scattering).
28193 CALL PYSGHG(NCHN,SIGS)
28194 ELSEIF(MAP.EQ.5) THEN
28196 CALL PYSGSU(NCHN,SIGS)
28197 ELSEIF(MAP.EQ.6) THEN
28199 CALL PYSGTC(NCHN,SIGS)
28200 ELSEIF(MAP.EQ.7) THEN
28201 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28202 CALL PYSGEX(NCHN,SIGS)
28205 C...Multiply with parton distributions
28206 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
28208 IF(MINT(45).GE.2) THEN
28210 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
28212 IF(MINT(46).GE.2) THEN
28214 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
28216 SIGS=SIGS+SIGH(ICHN)
28223 C*********************************************************************
28226 C...Subprocess cross sections for QCD processes,
28227 C...including photons.
28228 C...Auxiliary to PYSIGH.
28230 SUBROUTINE PYSGQC(NCHN,SIGS)
28232 C...Double precision and integer declarations
28233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28234 IMPLICIT INTEGER(I-N)
28235 INTEGER PYK,PYCHGE,PYCOMP
28236 C...Parameter statement to help give large particle numbers.
28237 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28238 &KEXCIT=4000000,KDIMEN=5000000)
28240 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28241 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28242 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28243 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28244 COMMON/PYINT1/MINT(400),VINT(400)
28245 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28246 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28247 COMMON/PYINT4/MWID(500),WIDS(500,5)
28248 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28249 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28250 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28251 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28252 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28253 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
28254 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
28256 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
28258 C...Differential cross section expressions.
28260 IF(ISUB.LE.20) THEN
28261 IF(ISUB.EQ.10) THEN
28262 C...f + f' -> f + f' (gamma/Z/W exchange)
28263 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
28264 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
28265 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
28266 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
28267 DO 110 I=MMIN1,MMAX1
28268 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
28270 DO 100 J=MMIN2,MMAX2
28271 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
28273 C...Electroweak couplings
28274 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
28275 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
28277 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
28278 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
28281 C...gamma/Z exchange, only gamma exchange, or only Z exchange
28282 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
28283 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
28284 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
28285 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
28286 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
28287 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
28288 ELSEIF(MSTP(21).EQ.2) THEN
28289 FACNCF=FACGGF*EI**2*EJ**2
28291 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
28292 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
28294 C...Extrafactor 2 for only one incoming neutrino spin state.
28295 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
28296 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
28304 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
28305 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
28306 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
28307 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
28308 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
28318 ELSEIF(ISUB.EQ.11) THEN
28319 C...f + f' -> f + f' (g exchange)
28320 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
28321 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
28322 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
28323 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
28324 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
28325 DO 130 I=MMIN1,MMAX1
28327 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
28328 DO 120 J=MMIN2,MMAX2
28330 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
28336 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
28338 SIGH(NCHN)=0.5D0*SIGH(NCHN)
28343 SIGH(NCHN)=0.5D0*FACQQ2
28348 ELSEIF(ISUB.EQ.12) THEN
28349 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
28350 CALL PYWIDT(21,SH,WDTP,WDTE)
28351 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
28352 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
28353 DO 140 I=MMINA,MMAXA
28354 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28355 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
28363 ELSEIF(ISUB.EQ.13) THEN
28364 C...f + fbar -> g + g (q + qbar -> g + g only)
28365 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28367 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28369 DO 150 I=MMINA,MMAXA
28370 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28371 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
28376 SIGH(NCHN)=0.5D0*FACGG1
28381 SIGH(NCHN)=0.5D0*FACGG2
28384 ELSEIF(ISUB.EQ.14) THEN
28385 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
28386 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
28387 DO 160 I=MMINA,MMAXA
28388 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28389 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
28390 EI=KCHG(IABS(I),1)/3D0
28395 SIGH(NCHN)=FACGG*EI**2
28398 ELSEIF(ISUB.EQ.18) THEN
28399 C...f + fbar -> gamma + gamma
28400 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
28401 DO 170 I=MMINA,MMAXA
28402 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
28403 EI=KCHG(IABS(I),1)/3D0
28405 IF(IABS(I).LE.10) FCOI=FACA/3D0
28410 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
28414 ELSEIF(ISUB.LE.40) THEN
28415 IF(ISUB.EQ.28) THEN
28416 C...f + g -> f + g (q + g -> q + g only)
28417 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
28419 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
28421 DO 190 I=MMINA,MMAXA
28422 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
28424 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
28425 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
28428 ISIG(NCHN,3-ISDE)=21
28433 ISIG(NCHN,3-ISDE)=21
28439 ELSEIF(ISUB.EQ.29) THEN
28440 C...f + g -> f + gamma (q + g -> q + gamma only)
28441 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
28442 DO 210 I=MMINA,MMAXA
28443 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
28444 EI=KCHG(IABS(I),1)/3D0
28447 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
28448 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
28451 ISIG(NCHN,3-ISDE)=21
28457 ELSEIF(ISUB.EQ.33) THEN
28458 C...f + gamma -> f + g (q + gamma -> q + g only)
28459 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
28460 DO 230 I=MMINA,MMAXA
28461 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
28462 EI=KCHG(IABS(I),1)/3D0
28465 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
28466 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
28469 ISIG(NCHN,3-ISDE)=22
28475 ELSEIF(ISUB.EQ.34) THEN
28476 C...f + gamma -> f + gamma
28477 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
28478 DO 250 I=MMINA,MMAXA
28479 IF(I.EQ.0) GOTO 250
28480 EI=KCHG(IABS(I),1)/3D0
28483 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
28484 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
28487 ISIG(NCHN,3-ISDE)=22
28494 ELSEIF(ISUB.LE.80) THEN
28495 IF(ISUB.EQ.53) THEN
28496 C...g + g -> f + fbar (g + g -> q + qbar only)
28497 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
28499 C...Begin by d, u, s flavours.
28501 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
28502 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
28503 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
28504 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
28505 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
28506 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
28507 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28508 & UH2/SH2)*FLAVWT*FACA
28509 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28510 & TH2/SH2)*FLAVWT*FACA
28521 C...Next c and b flavours: modified that and uhat for fixed
28522 C...cos(theta-hat).
28524 SQMAVG=PMAS(IFL,1)**2
28525 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
28526 BE34=SQRT(1D0-4D0*SQMAVG/SH)
28527 THQ=-0.5D0*SH*(1D0-BE34*CTH)
28528 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
28529 THUHQ=THQ*UHQ-SQMAVG*SH
28530 IF(MSTP(34).EQ.0) THEN
28531 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
28532 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
28534 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28535 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
28536 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28537 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
28539 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
28540 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
28544 ISIG(NCHN,3)=1+2*(IFL-3)
28549 ISIG(NCHN,3)=2+2*(IFL-3)
28555 ELSEIF(ISUB.EQ.54) THEN
28556 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
28557 CALL PYWIDT(21,SH,WDTP,WDTE)
28559 DO 280 I=1,MIN(8,MDCY(21,3))
28561 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
28564 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
28565 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
28572 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
28580 ELSEIF(ISUB.EQ.58) THEN
28581 C...gamma + gamma -> f + fbar
28582 CALL PYWIDT(22,SH,WDTP,WDTE)
28584 DO 290 I=1,MIN(12,MDCY(22,3))
28585 IF(I.LE.8) EF= KCHG(I,1)/3D0
28586 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
28587 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
28590 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
28591 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
28599 ELSEIF(ISUB.EQ.68) THEN
28601 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
28602 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
28604 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
28606 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
28612 SIGH(NCHN)=0.5D0*FACGG1
28617 SIGH(NCHN)=0.5D0*FACGG2
28622 SIGH(NCHN)=0.5D0*FACGG3
28625 ELSEIF(ISUB.EQ.80) THEN
28626 C...q + gamma -> q' + pi+/-
28627 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
28628 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
28629 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
28630 DELSH=UH*SQRT(ASSH*Q2FPSH)
28631 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
28632 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
28633 DELUH=SH*SQRT(ASUH*Q2FPUH)
28634 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
28635 IF(I.EQ.0) GOTO 320
28636 EI=KCHG(IABS(I),1)/3D0
28637 EJ=SIGN(1D0-ABS(EI),EI)
28639 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
28640 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
28643 ISIG(NCHN,3-ISDE)=22
28645 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
28650 ELSEIF(ISUB.LE.100) THEN
28651 IF(ISUB.EQ.91) THEN
28652 C...Elastic scattering
28653 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
28655 ELSEIF(ISUB.EQ.92) THEN
28656 C...Single diffractive scattering (first side, i.e. XB)
28657 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
28659 ELSEIF(ISUB.EQ.93) THEN
28660 C...Single diffractive scattering (second side, i.e. AX)
28661 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
28663 ELSEIF(ISUB.EQ.94) THEN
28664 C...Double diffractive scattering
28665 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
28667 ELSEIF(ISUB.EQ.95) THEN
28668 C...Low-pT scattering
28669 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
28671 ELSEIF(ISUB.EQ.96) THEN
28672 C...Multiple interactions: sum of QCD processes
28673 CALL PYWIDT(21,SH,WDTP,WDTE)
28675 C...q + q' -> q + q'
28676 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
28677 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
28678 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
28679 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
28680 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
28681 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
28683 IF(I.EQ.0) GOTO 340
28685 IF(J.EQ.0) GOTO 330
28691 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
28693 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
28698 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
28703 C...q + qbar -> q' + qbar' or g + g
28704 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
28705 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
28706 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28708 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28711 IF(I.EQ.0) GOTO 350
28721 SIGH(NCHN)=0.5D0*FACGG1
28726 SIGH(NCHN)=0.5D0*FACGG2
28730 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
28732 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
28735 IF(I.EQ.0) GOTO 370
28739 ISIG(NCHN,3-ISDE)=21
28744 ISIG(NCHN,3-ISDE)=21
28750 C...g + g -> q + qbar (only d, u, s)
28753 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
28754 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
28755 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
28756 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
28757 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
28758 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
28759 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28760 & UH2/SH2)*FLAVWT*FACA
28761 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28762 & TH2/SH2)*FLAVWT*FACA
28774 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
28777 SQMAVG=PMAS(IFL,1)**2
28778 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
28779 BE34=SQRT(1D0-4D0*SQMAVG/SH)
28780 THQ=-0.5D0*SH*(1D0-BE34*CTH)
28781 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
28782 THUHQ=THQ*UHQ-SQMAVG*SH
28783 IF(MSTP(34).EQ.0) THEN
28784 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
28785 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
28787 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28788 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
28789 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28790 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
28792 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
28793 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
28797 ISIG(NCHN,3)=531+2*(IFL-3)
28802 ISIG(NCHN,3)=532+2*(IFL-3)
28808 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
28809 & 2D0*TH/SH+TH2/SH2)*FACA
28810 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
28811 & 2D0*SH/UH+SH2/UH2)*FACA
28812 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
28813 & 2D0*UH/TH+UH2/TH2)
28818 SIGH(NCHN)=0.5D0*FACGG1
28823 SIGH(NCHN)=0.5D0*FACGG2
28828 SIGH(NCHN)=0.5D0*FACGG3
28830 ELSEIF(ISUB.EQ.99) THEN
28831 C...f + gamma* -> f.
28832 IF(MINT(107).EQ.4) THEN
28841 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
28842 PM2RHO=PMAS(PYCOMP(113),1)**2
28843 IF(MSTP(19).EQ.0) THEN
28845 ELSEIF(MSTP(19).EQ.1) THEN
28846 COMFAC=COMFAC/(Q2GA+PM2RHO)
28847 ELSEIF(MSTP(19).EQ.2) THEN
28848 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
28850 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
28852 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
28853 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
28854 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
28855 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
28857 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
28859 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
28861 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
28862 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
28864 DO 390 I=MMINA,MMAXA
28865 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
28866 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
28867 EI=KCHG(IABS(I),1)/3D0
28870 ISIG(NCHN,3-ISDE)=22
28872 SIGH(NCHN)=COMFAC*EI**2
28877 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
28878 C...g + g -> gamma + gamma or g + g -> g + gamma
28893 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
28895 EI=KCHG(IABS(I),1)/3D0
28897 IF(ISUB.EQ.115) EIWT=EI
28902 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
28903 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
28906 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
28907 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
28908 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
28909 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
28915 CALL PYWAUX(1,EPSS,W1SR,W1SI)
28916 CALL PYWAUX(1,EPST,W1TR,W1TI)
28917 CALL PYWAUX(1,EPSU,W1UR,W1UI)
28918 CALL PYWAUX(2,EPSS,W2SR,W2SI)
28919 CALL PYWAUX(2,EPST,W2TR,W2TI)
28920 CALL PYWAUX(2,EPSU,W2UR,W2UI)
28921 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
28922 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
28923 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
28924 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
28925 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
28926 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
28927 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
28928 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
28929 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
28930 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
28931 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
28932 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
28933 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
28934 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
28935 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
28936 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
28937 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
28938 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
28939 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
28940 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
28941 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
28942 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
28943 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
28944 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
28945 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
28946 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
28947 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
28948 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
28949 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
28950 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
28951 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
28952 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
28953 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
28954 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
28955 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
28956 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
28957 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
28958 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
28959 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
28960 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
28961 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
28962 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
28963 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
28964 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
28965 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
28966 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
28967 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
28968 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
28969 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
28970 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
28971 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
28972 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
28973 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
28974 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
28975 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
28976 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
28978 A0STUR=A0STUR+EIWT*B0STUR
28979 A0STUI=A0STUI+EIWT*B0STUI
28980 A0TSUR=A0TSUR+EIWT*B0TSUR
28981 A0TSUI=A0TSUI+EIWT*B0TSUI
28982 A0UTSR=A0UTSR+EIWT*B0UTSR
28983 A0UTSI=A0UTSI+EIWT*B0UTSI
28984 A1STUR=A1STUR+EIWT*B1STUR
28985 A1STUI=A1STUI+EIWT*B1STUI
28986 A2STUR=A2STUR+EIWT*B2STUR
28987 A2STUI=A2STUI+EIWT*B2STUI
28989 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
28990 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
28991 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
28992 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
28993 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
28998 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
28999 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29002 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29003 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29005 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29007 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29009 IF(ISUB.EQ.131) THEN
29010 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29011 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29013 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29015 DO 430 I=MMINA,MMAXA
29016 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29017 EI=KCHG(IABS(I),1)/3D0
29020 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29021 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29024 ISIG(NCHN,3-ISDE)=22
29030 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29031 C...f + gamma*_(T,L) -> f + gamma
29033 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29035 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29037 IF(ISUB.EQ.133) THEN
29038 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29039 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29041 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29043 DO 450 I=MMINA,MMAXA
29044 IF(I.EQ.0) GOTO 450
29045 EI=KCHG(IABS(I),1)/3D0
29048 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29049 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29052 ISIG(NCHN,3-ISDE)=22
29058 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29059 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29061 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29063 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29065 CALL PYWIDT(21,SH,WDTP,WDTE)
29067 DO 460 I=1,MIN(8,MDCY(21,3))
29069 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29072 IF(ISUB.EQ.135) THEN
29073 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29074 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29076 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29078 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29085 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29093 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
29094 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
29096 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
29098 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
29099 CALL PYWIDT(22,SH,WDTP,WDTE)
29101 DO 470 I=1,MIN(12,MDCY(22,3))
29102 IF(I.LE.8) EF= KCHG(I,1)/3D0
29103 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29104 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29107 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
29108 IF(ISUB.EQ.137) THEN
29109 FPARAM=-SH*(TH+UH)/DLAMB2
29110 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
29111 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
29112 & 2D0*PH1*PH2*FPARAM**2)
29113 ELSEIF(ISUB.EQ.138) THEN
29114 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
29115 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
29116 & 2D0*PH1**2*(TH-UH)**2)
29117 ELSEIF(ISUB.EQ.139) THEN
29118 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
29119 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
29120 & 2D0*PH2**2*(TH-UH)**2)
29122 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
29123 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
29125 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29139 C*********************************************************************
29142 C...Subprocess cross sections for heavy flavour production,
29143 C...open and closed.
29144 C...Auxiliary to PYSIGH.
29146 SUBROUTINE PYSGHF(NCHN,SIGS)
29148 C...Double precision and integer declarations
29149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29150 IMPLICIT INTEGER(I-N)
29151 INTEGER PYK,PYCHGE,PYCOMP
29152 C...Parameter statement to help give large particle numbers.
29153 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29154 &KEXCIT=4000000,KDIMEN=5000000)
29156 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29157 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29159 COMMON/PYINT1/MINT(400),VINT(400)
29160 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29161 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29162 COMMON/PYINT4/MWID(500),WIDS(500,5)
29163 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29164 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29165 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29166 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29167 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
29170 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29172 C...Determine where are charmonium/bottomonium wave function parameters.
29174 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
29176 C...Convert bottomonium process into equivalent charmonium ones.
29177 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
29179 C...Differential cross section expressions.
29181 IF(ISUB.LE.100) THEN
29182 IF(ISUB.EQ.81) THEN
29183 C...q + qbar -> Q + Qbar
29184 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29185 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29186 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29187 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
29189 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
29191 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29192 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29194 DO 100 I=MMINA,MMAXA
29195 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29196 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
29204 ELSEIF(ISUB.EQ.82) THEN
29205 C...g + g -> Q + Qbar
29206 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29207 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29208 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29209 THUHQ=THQ*UHQ-SQMAVG*SH
29210 IF(MSTP(34).EQ.0) THEN
29211 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29212 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29214 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29215 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29216 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29217 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29219 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
29220 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
29221 IF(MSTP(35).GE.1) THEN
29222 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
29223 FACQQ1=FACQQ1*FATRE
29224 FACQQ2=FACQQ2*FATRE
29227 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29228 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29231 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
29244 ELSEIF(ISUB.EQ.83) THEN
29245 C...f + q -> f' + Q
29246 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
29247 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
29248 DO 130 I=MMIN1,MMAX1
29249 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
29250 DO 120 J=MMIN2,MMAX2
29251 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
29252 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
29253 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
29254 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
29260 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
29261 & (IABS(I)+1)/2)*VINT(180+J)
29262 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
29263 & (MINT(55)+1)/2)*VINT(180+J)
29266 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
29267 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29270 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
29271 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29274 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
29275 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
29277 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
29283 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
29284 & (IABS(J)+1)/2)*VINT(180+I)
29285 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
29286 & (MINT(55)+1)/2)*VINT(180+I)
29288 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
29289 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29292 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
29293 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29296 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
29297 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
29302 ELSEIF(ISUB.EQ.84) THEN
29303 C...g + gamma -> Q + Qbar
29304 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29305 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29306 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29307 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
29308 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
29310 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
29312 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29313 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29315 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29322 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29330 ELSEIF(ISUB.EQ.85) THEN
29331 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
29332 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29333 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29334 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29335 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
29336 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
29337 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
29338 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
29339 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
29340 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
29341 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
29343 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
29344 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
29345 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
29347 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29355 ELSEIF(ISUB.EQ.86) THEN
29356 C...g + g -> J/Psi + g
29357 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
29358 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29359 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29360 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29368 ELSEIF(ISUB.EQ.87) THEN
29369 C...g + g -> chi_0c + g
29370 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29371 QGTW=(SH*TH*UH)/SH**3
29373 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29374 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
29375 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
29376 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
29377 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
29378 & (QGTW*(QGTW-RGTW*PGTW)**4)
29379 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29387 ELSEIF(ISUB.EQ.88) THEN
29388 C...g + g -> chi_1c + g
29389 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29390 QGTW=(SH*TH*UH)/SH**3
29392 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29393 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
29394 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
29395 & (QGTW-RGTW*PGTW)**4
29396 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29404 ELSEIF(ISUB.EQ.89) THEN
29405 C...g + g -> chi_2c + g
29406 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29407 QGTW=(SH*TH*UH)/SH**3
29409 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29410 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
29411 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
29412 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
29413 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
29414 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
29415 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29424 ELSEIF(ISUB.LE.200) THEN
29425 IF(ISUB.EQ.104) THEN
29426 C...g + g -> chi_c0.
29428 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
29429 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
29430 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
29431 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29439 ELSEIF(ISUB.EQ.105) THEN
29440 C...g + g -> chi_c2.
29442 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
29443 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
29444 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
29445 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29453 ELSEIF(ISUB.EQ.106) THEN
29454 C...g + g -> J/Psi + gamma.
29455 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29456 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
29457 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29458 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29459 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29467 ELSEIF(ISUB.EQ.107) THEN
29468 C...g + gamma -> J/Psi + g.
29469 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29470 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
29471 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29472 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29473 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29480 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29488 ELSEIF(ISUB.EQ.108) THEN
29489 C...gamma + gamma -> J/Psi + gamma.
29490 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29491 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
29492 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29493 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29494 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29504 C...Additional code by Stefan Wolf
29507 C...Common code for quarkonium production.
29514 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
29515 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
29517 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
29518 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
29522 IF(MSTP(145).EQ.1) THEN
29523 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
29524 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
29525 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
29526 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
29527 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
29528 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
29529 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
29530 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
29531 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
29532 & ISUB.GE.437) THEN
29533 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
29534 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
29535 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
29536 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
29537 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
29538 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
29542 SMQQ2=SQMQQ*VINT(2)
29543 C...Polarisation frames
29544 IF(MSTP(146).EQ.1) THEN
29546 POLH1=SQRT(AQ2-SMQQ2)
29547 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29550 AX=AQ*BQ/(POLH1*POLH2)
29552 ELSEIF(MSTP(146).EQ.2) THEN
29553 C...Gottfried Jackson frame
29555 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29558 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
29559 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
29560 ELSEIF(MSTP(146).EQ.3) THEN
29563 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29566 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
29567 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
29568 ELSEIF(MSTP(146).EQ.4) THEN
29569 C...Collins Soper frame
29571 POLH2=SQRT(VINT(2)*POLH1)
29574 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
29575 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
29577 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
29578 EL1K10=AZ*ATILK1+BZ*BTILK1
29579 EL1K20=AZ*ATILK2+BZ*BTILK2
29582 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
29583 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
29588 IF(ISUB.EQ.421) THEN
29589 C...g + g -> QQ~[3S11] + g
29590 IF(MSTP(145).EQ.0) THEN
29591 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29592 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
29593 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29594 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
29595 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29596 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
29598 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
29599 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
29603 IF(MSTP(147).EQ.0) THEN
29604 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29605 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29606 ELSEIF(MSTP(147).EQ.1) THEN
29607 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29608 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29609 ELSEIF(MSTP(147).EQ.3) THEN
29610 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29611 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29612 ELSEIF(MSTP(147).EQ.4) THEN
29613 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29614 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29615 ELSEIF(MSTP(147).EQ.5) THEN
29616 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29617 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29618 ELSEIF(MSTP(147).EQ.6) THEN
29619 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29620 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29622 FACQQG=COMFAC*FF*FACQQG
29624 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29629 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
29632 ELSEIF(ISUB.EQ.422) THEN
29633 C...g + g -> QQ~[3S18] + g
29634 IF(MSTP(145).EQ.0) THEN
29635 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
29636 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
29638 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
29640 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
29641 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
29642 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
29646 IF(MSTP(147).EQ.0) THEN
29647 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29648 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29649 ELSEIF(MSTP(147).EQ.1) THEN
29650 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29651 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29652 ELSEIF(MSTP(147).EQ.3) THEN
29653 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29654 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29655 ELSEIF(MSTP(147).EQ.4) THEN
29656 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29657 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29658 ELSEIF(MSTP(147).EQ.5) THEN
29659 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29660 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29661 ELSEIF(MSTP(147).EQ.6) THEN
29662 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29663 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29665 FACQQG=COMFAC*FF*FACQQG
29667 C...Split total contribution into different colour flows just like
29668 C...in g g -> g g (recalculate kinematics for massless partons).
29669 THP=-0.5D0*SH*(1D0-CTH)
29670 UHP=-0.5D0*SH*(1D0+CTH)
29671 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29672 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29673 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29674 FACGGS=FACGG1+FACGG2+FACGG3
29675 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29680 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
29685 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
29690 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
29693 ELSEIF(ISUB.EQ.423) THEN
29694 C...g + g -> QQ~[1S08] + g
29695 IF(MSTP(145).EQ.0) THEN
29696 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
29697 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
29698 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
29699 * & (SHTH2*THUH2*UHSH2)
29700 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
29701 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
29702 & TH2/(SHTH2*THUH2))*
29703 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
29705 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
29706 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
29707 & TH2/(SHTH2*THUH2))*
29708 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
29709 IF(MSTP(147).EQ.0) THEN
29711 ELSEIF(MSTP(147).EQ.1) THEN
29712 FACQQG=COMFAC*2D0*FA
29713 ELSEIF(MSTP(147).EQ.3) THEN
29715 ELSEIF(MSTP(147).EQ.4) THEN
29717 ELSEIF(MSTP(147).EQ.5) THEN
29719 ELSEIF(MSTP(147).EQ.6) THEN
29723 C...Split total contribution into different colour flows just like
29724 C...in g g -> g g (recalculate kinematics for massless partons).
29725 THP=-0.5D0*SH*(1D0-CTH)
29726 UHP=-0.5D0*SH*(1D0+CTH)
29727 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29728 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29729 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29730 FACGGS=FACGG1+FACGG2+FACGG3
29731 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29736 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
29741 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
29746 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
29749 ELSEIF(ISUB.EQ.424) THEN
29750 C...g + g -> QQ~[3PJ8] + g
29752 IF(MSTP(145).EQ.0) THEN
29753 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
29754 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
29755 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
29757 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
29758 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
29759 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
29761 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
29762 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
29763 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
29765 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
29766 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
29767 & +451D0*SH*TH**5+126D0*TH**6)
29768 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
29769 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
29770 & +171D0*SH*TH**5+42D0*TH**6)
29771 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
29772 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
29773 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
29774 & +99D0*SH*TH**3+35D0*TH**4)
29775 & +7D0*SQMQQ**8*SHTH*POLY)/
29776 & (SH*TH*UH*SQMQQR*SQMQQ*
29777 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
29779 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
29780 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
29781 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
29782 & -SQMQQ*SHTH2*POLY**2*
29783 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
29784 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
29785 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
29786 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
29787 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
29788 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
29789 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
29790 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
29791 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
29792 & +145D0*SH*TH**5+34D0*TH**6)
29793 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
29794 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
29796 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
29797 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
29798 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
29799 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
29800 & +3D0*SQMQQ**8*SHTH*POLY)
29801 BB=4D0*SHTH2*POLY**3
29802 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
29803 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
29804 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
29805 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
29806 & +84D0*SH*TH**9+20D0*TH**10)
29807 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
29808 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
29809 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
29811 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
29812 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
29813 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
29815 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
29816 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
29817 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
29818 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
29819 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
29821 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
29822 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
29823 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
29825 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
29826 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
29827 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
29828 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
29830 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
29831 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
29832 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
29833 & +394D0*SH*TH**9+84D0*TH**10)
29834 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
29835 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
29836 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
29837 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
29838 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
29839 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
29840 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
29841 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
29842 & +266D0*SH*TH**6+84D0*TH**7)
29843 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
29844 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
29846 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
29847 & +7D0*SH*TH**3+4*TH**4)
29848 & +SQMQQ**8*SH*(SH-TH)**2*TH
29849 DD=2D0*TH2*SHTH2*POLY**3
29850 & *(-SH2+2*SH*TH+2*TH2)
29851 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
29852 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
29853 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
29854 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
29855 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
29856 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
29857 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
29858 & -210D0*SH*TH**8-60D0*TH**9)
29859 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
29860 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
29861 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
29863 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
29864 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
29865 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
29866 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
29867 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
29868 & -30D0*SH*TH**6-24D0*TH**7)
29869 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
29870 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
29872 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
29873 IF(MSTP(147).EQ.0) THEN
29874 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29875 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29876 ELSEIF(MSTP(147).EQ.1) THEN
29877 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29878 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29879 ELSEIF(MSTP(147).EQ.3) THEN
29880 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29881 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29882 ELSEIF(MSTP(147).EQ.4) THEN
29883 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29884 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29885 ELSEIF(MSTP(147).EQ.5) THEN
29886 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29887 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29888 ELSEIF(MSTP(147).EQ.6) THEN
29889 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29890 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29892 FACQQG=COMFAC*FF*FACQQG
29894 C...Split total contribution into different colour flows just like
29895 C...in g g -> g g (recalculate kinematics for massless partons).
29896 THP=-0.5D0*SH*(1D0-CTH)
29897 UHP=-0.5D0*SH*(1D0+CTH)
29898 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29899 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29900 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29901 FACGGS=FACGG1+FACGG2+FACGG3
29902 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29907 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
29912 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
29917 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
29920 ELSEIF(ISUB.EQ.425) THEN
29921 C...q + g -> q + QQ~[3S18]
29922 IF(MSTP(145).EQ.0) THEN
29923 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
29924 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
29925 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
29927 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
29928 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
29933 IF(MSTP(147).EQ.0) THEN
29934 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29935 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29936 ELSEIF(MSTP(147).EQ.1) THEN
29937 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29938 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29939 ELSEIF(MSTP(147).EQ.3) THEN
29940 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29941 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29942 ELSEIF(MSTP(147).EQ.4) THEN
29943 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29944 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29945 ELSEIF(MSTP(147).EQ.5) THEN
29946 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29947 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29948 ELSEIF(MSTP(147).EQ.6) THEN
29949 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29950 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29952 FACQQG=COMFAC*FF*FACQQG
29954 C...Split total contribution into different colour flows just like
29955 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
29956 C...(recalculate kinematics for massless partons).
29957 THP=-0.5D0*SH*(1D0-CTH)
29958 UHP=-0.5D0*SH*(1D0+CTH)
29959 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
29960 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
29961 FACQGS=FACQG1+FACQG2
29962 DO 2442 I=MMINA,MMAXA
29963 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
29965 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
29966 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
29969 ISIG(NCHN,3-ISDE)=21
29971 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
29974 ISIG(NCHN,3-ISDE)=21
29976 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
29980 ELSEIF(ISUB.EQ.426) THEN
29981 C...q + g -> q + QQ~[1S08]
29982 IF(MSTP(145).EQ.0) THEN
29983 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
29984 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
29986 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
29987 IF(MSTP(147).EQ.0) THEN
29989 ELSEIF(MSTP(147).EQ.1) THEN
29990 FACQQG=COMFAC*2D0*FA
29991 ELSEIF(MSTP(147).EQ.3) THEN
29993 ELSEIF(MSTP(147).EQ.4) THEN
29995 ELSEIF(MSTP(147).EQ.5) THEN
29997 ELSEIF(MSTP(147).EQ.6) THEN
30001 C...Split total contribution into different colour flows just like
30002 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30003 C...(recalculate kinematics for massless partons).
30004 THP=-0.5D0*SH*(1D0-CTH)
30005 UHP=-0.5D0*SH*(1D0+CTH)
30006 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30007 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30008 FACQGS=FACQG1+FACQG2
30009 DO 2444 I=MMINA,MMAXA
30010 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30012 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30013 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30016 ISIG(NCHN,3-ISDE)=21
30018 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30021 ISIG(NCHN,3-ISDE)=21
30023 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30027 ELSEIF(ISUB.EQ.427) THEN
30028 C...q + g -> q + QQ~[3PJ8]
30029 IF(MSTP(145).EQ.0) THEN
30030 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30031 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30032 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30033 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30035 FF=10D0*PARU(1)*AS**3/
30036 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30037 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30038 BB=8D0*(SHTH2+TH*UH)
30039 CC=8D0*UHSH*(SHTH+THUH)
30040 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30041 IF(MSTP(147).EQ.0) THEN
30042 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30043 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30044 ELSEIF(MSTP(147).EQ.1) THEN
30045 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30046 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30047 ELSEIF(MSTP(147).EQ.3) THEN
30048 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30049 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30050 ELSEIF(MSTP(147).EQ.4) THEN
30051 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30052 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30053 ELSEIF(MSTP(147).EQ.5) THEN
30054 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30055 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30056 ELSEIF(MSTP(147).EQ.6) THEN
30057 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30058 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30060 FACQQG=COMFAC*FF*FACQQG
30062 C...Split total contribution into different colour flows just like
30063 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30064 C...(recalculate kinematics for massless partons).
30065 THP=-0.5D0*SH*(1D0-CTH)
30066 UHP=-0.5D0*SH*(1D0+CTH)
30067 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30068 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30069 FACQGS=FACQG1+FACQG2
30070 DO 2446 I=MMINA,MMAXA
30071 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30073 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30074 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30077 ISIG(NCHN,3-ISDE)=21
30079 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
30082 ISIG(NCHN,3-ISDE)=21
30084 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
30088 ELSEIF(ISUB.EQ.428) THEN
30089 C...q + q~ -> g + QQ~[3S18]
30090 IF(MSTP(145).EQ.0) THEN
30091 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
30092 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
30093 & (SQMQQ*SQMQQR*TH*UH*THUH2)
30095 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
30096 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
30101 IF(MSTP(147).EQ.0) THEN
30102 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30103 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30104 ELSEIF(MSTP(147).EQ.1) THEN
30105 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30106 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30107 ELSEIF(MSTP(147).EQ.3) THEN
30108 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30109 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30110 ELSEIF(MSTP(147).EQ.4) THEN
30111 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30112 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30113 ELSEIF(MSTP(147).EQ.5) THEN
30114 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30115 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30116 ELSEIF(MSTP(147).EQ.6) THEN
30117 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30118 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30120 FACQQG=COMFAC*FF*FACQQG
30122 C...Split total contribution into different colour flows just like
30123 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30124 C...(recalculate kinematics for massless partons).
30125 THP=-0.5D0*SH*(1D0-CTH)
30126 UHP=-0.5D0*SH*(1D0+CTH)
30127 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30128 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30129 FACGGS=FACGG1+FACGG2
30130 DO 2447 I=MMINA,MMAXA
30131 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30132 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
30137 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30142 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30145 ELSEIF(ISUB.EQ.429) THEN
30146 C...q + q~ -> g + QQ~[1S08]
30147 IF(MSTP(145).EQ.0) THEN
30148 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
30149 & (TH2+UH2)/(SQMQQR*SH*THUH2)
30151 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
30152 IF(MSTP(147).EQ.0) THEN
30154 ELSEIF(MSTP(147).EQ.1) THEN
30155 FACQQG=COMFAC*2D0*FA
30156 ELSEIF(MSTP(147).EQ.3) THEN
30158 ELSEIF(MSTP(147).EQ.4) THEN
30160 ELSEIF(MSTP(147).EQ.5) THEN
30162 ELSEIF(MSTP(147).EQ.6) THEN
30166 C...Split total contribution into different colour flows just like
30167 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30168 C...(recalculate kinematics for massless partons).
30169 THP=-0.5D0*SH*(1D0-CTH)
30170 UHP=-0.5D0*SH*(1D0+CTH)
30171 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30172 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30173 FACGGS=FACGG1+FACGG2
30174 DO 2448 I=MMINA,MMAXA
30175 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30176 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
30181 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30186 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30189 ELSEIF(ISUB.EQ.430) THEN
30190 C...q + q~ -> g + QQ~[3PJ8]
30191 IF(MSTP(145).EQ.0) THEN
30192 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
30193 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
30194 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
30195 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
30197 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
30198 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
30199 BB=8D0*(UHSH2+SH*TH)
30200 CC=8D0*(SHTH2+SH*UH)
30201 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
30202 IF(MSTP(147).EQ.0) THEN
30203 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30204 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30205 ELSEIF(MSTP(147).EQ.1) THEN
30206 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30207 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30208 ELSEIF(MSTP(147).EQ.3) THEN
30209 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30210 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30211 ELSEIF(MSTP(147).EQ.4) THEN
30212 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30213 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30214 ELSEIF(MSTP(147).EQ.5) THEN
30215 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30216 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30217 ELSEIF(MSTP(147).EQ.6) THEN
30218 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30219 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30221 FACQQG=COMFAC*FF*FACQQG
30223 C...Split total contribution into different colour flows just like
30224 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30225 C...(recalculate kinematics for massless partons).
30226 THP=-0.5D0*SH*(1D0-CTH)
30227 UHP=-0.5D0*SH*(1D0+CTH)
30228 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30229 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30230 FACGGS=FACGG1+FACGG2
30231 DO 2449 I=MMINA,MMAXA
30232 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30233 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
30238 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30243 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30246 ELSEIF(ISUB.EQ.431) THEN
30247 C...g + g -> QQ~[3P01] + g
30248 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30249 QGTW=(SH*TH*UH)/SH**3
30251 IF(MSTP(145).EQ.0) THEN
30252 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
30253 & (9D0*RGTW**2*PGTW**4*
30254 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30255 & -6D0*RGTW*PGTW**3*QGTW*
30256 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
30257 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
30258 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
30259 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30261 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
30262 & (9D0*RGTW**2*PGTW**4*
30263 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30264 & -6D0*RGTW*PGTW**3*QGTW*
30265 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
30266 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
30267 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
30268 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30269 IF(MSTP(147).EQ.0) THEN
30271 ELSEIF(MSTP(147).EQ.1) THEN
30272 FACQQG=COMFAC*2D0*FC1
30273 ELSEIF(MSTP(147).EQ.3) THEN
30275 ELSEIF(MSTP(147).EQ.4) THEN
30277 ELSEIF(MSTP(147).EQ.5) THEN
30279 ELSEIF(MSTP(147).EQ.6) THEN
30283 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30288 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30291 ELSEIF(ISUB.EQ.432) THEN
30292 C...g + g -> QQ~[3P11] + g
30293 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30294 QGTW=(SH*TH*UH)/SH**3
30296 IF(MSTP(145).EQ.0) THEN
30297 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
30298 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
30299 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
30300 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
30302 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
30303 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
30304 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
30305 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
30306 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
30307 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
30308 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
30309 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
30310 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
30311 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
30312 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
30313 C4=-4D0*THUH*(TH-UH)**2*
30314 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
30315 & -SH2*TH*UH*(TH2+UH2))
30316 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
30317 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
30318 & +SH2*(5D0*THUH2-17D0*TH*UH)))
30319 IF(MSTP(147).EQ.0) THEN
30320 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30321 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30322 ELSEIF(MSTP(147).EQ.1) THEN
30323 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30324 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30325 ELSEIF(MSTP(147).EQ.3) THEN
30326 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30327 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30328 ELSEIF(MSTP(147).EQ.4) THEN
30329 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30330 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30331 ELSEIF(MSTP(147).EQ.5) THEN
30332 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30333 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30334 ELSEIF(MSTP(147).EQ.6) THEN
30335 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30336 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30338 FACQQG=COMFAC*FF*FACQQG
30340 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30345 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30348 ELSEIF(ISUB.EQ.433) THEN
30349 C...g + g -> QQ~[3P21] + g
30350 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30351 QGTW=(SH*TH*UH)/SH**3
30353 IF(MSTP(145).EQ.0) THEN
30354 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
30355 & (12D0*RGTW**2*PGTW**4*
30356 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30357 & -3D0*RGTW*PGTW**3*QGTW*
30358 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
30359 & +2D0*PGTW**2*QGTW**2*
30360 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
30361 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
30362 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30364 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
30365 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
30366 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
30368 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
30369 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
30370 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
30371 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
30372 & +10D0*(SH2**2+TH2**2))
30373 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
30374 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
30375 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
30376 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
30377 & +4D0*SH*TH*UH2**4*SHTH2)
30378 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
30379 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
30380 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
30381 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
30382 & +10D0*(SH2**2+UH2**2))
30383 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
30384 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
30385 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
30386 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
30387 & +4D0*SH*UH*TH2**4*UHSH2)
30388 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
30389 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
30390 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
30391 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
30392 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
30393 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
30394 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
30395 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
30396 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
30397 & +3D0*(TH2**3+UH2**3)))
30398 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
30399 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
30400 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
30401 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
30402 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
30403 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
30404 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
30406 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
30408 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
30410 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
30411 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
30412 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
30413 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
30414 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
30415 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
30417 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
30419 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
30421 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
30422 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
30423 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
30424 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
30425 & +4D0*SH*TH2**2*UH2**2*THUH2
30426 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
30427 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
30428 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
30429 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
30430 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
30431 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
30432 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
30433 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
30434 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
30435 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
30436 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
30437 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
30438 & +2D0*(TH2**3+UH2**3))
30439 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
30440 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
30441 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
30442 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
30443 IF(MSTP(147).EQ.0) THEN
30444 FACQQG=1D0/3D0*(C1*3D0
30445 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30446 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30447 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30448 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30449 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30450 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30451 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30452 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30453 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30454 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30455 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30456 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30457 ELSEIF(MSTP(147).EQ.1) THEN
30459 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30460 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30461 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30462 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30463 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30464 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30465 & +EL1K10*EL2K20*EL1K11*EL2K11)
30466 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30467 & +EL1K10*EL2K20*EL1K21*EL2K21)
30468 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30469 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30470 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30471 & +EL1K20*EL2K20*EL1K11*EL2K11)
30472 ELSEIF(MSTP(147).EQ.2) THEN
30474 & -C2*EL1K11*EL2K11
30475 & -C3*EL1K21*EL2K21
30476 & -C4*EL1K11*EL2K21
30477 & +C5*(EL1K11*EL2K11)**2
30478 & +C6*(EL1K21*EL2K21)**2
30479 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30480 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30481 & +(C9+C0)*(EL1K11*EL2K21)**2)
30483 FACQQG=COMFAC*FF*FACQQG
30485 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30490 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30493 ELSEIF(ISUB.EQ.434) THEN
30494 C...q + g -> q + QQ~[3P01]
30495 IF(MSTP(145).EQ.0) THEN
30496 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
30497 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
30499 FA=-PARU(1)*AS**3*(16D0/243D0)*
30500 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
30501 IF(MSTP(147).EQ.0) THEN
30503 ELSEIF(MSTP(147).EQ.1) THEN
30504 FACQQG=COMFAC*2D0*FA
30505 ELSEIF(MSTP(147).EQ.3) THEN
30507 ELSEIF(MSTP(147).EQ.4) THEN
30509 ELSEIF(MSTP(147).EQ.5) THEN
30511 ELSEIF(MSTP(147).EQ.6) THEN
30515 DO 2452 I=MMINA,MMAXA
30516 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
30518 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
30519 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
30522 ISIG(NCHN,3-ISDE)=21
30524 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30528 ELSEIF(ISUB.EQ.435) THEN
30529 C...q + g -> q + QQ~[3P11]
30530 IF(MSTP(145).EQ.0) THEN
30531 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
30532 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
30534 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
30539 IF(MSTP(147).EQ.0) THEN
30540 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30541 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30542 ELSEIF(MSTP(147).EQ.1) THEN
30543 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30544 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30545 ELSEIF(MSTP(147).EQ.3) THEN
30546 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30547 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30548 ELSEIF(MSTP(147).EQ.4) THEN
30549 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30550 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30551 ELSEIF(MSTP(147).EQ.5) THEN
30552 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30553 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30554 ELSEIF(MSTP(147).EQ.6) THEN
30555 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30556 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30558 FACQQG=COMFAC*FF*FACQQG
30560 DO 2454 I=MMINA,MMAXA
30561 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
30563 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
30564 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
30567 ISIG(NCHN,3-ISDE)=21
30569 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30573 ELSEIF(ISUB.EQ.436) THEN
30574 C...q + g -> q + QQ~[3P21]
30575 IF(MSTP(145).EQ.0) THEN
30576 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
30577 & ((6D0*SQMQQ**2+TH2)*UHSH2
30578 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
30579 & (SQMQQR*TH*UHSH2**2)
30581 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
30583 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
30592 IF(MSTP(147).EQ.0) THEN
30593 FACQQG=1D0/3D0*(C1*3D0
30594 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30595 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30596 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30597 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30598 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30599 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30600 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30601 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30602 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30603 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30604 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30605 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30606 ELSEIF(MSTP(147).EQ.1) THEN
30608 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30609 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30610 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30611 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30612 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30613 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30614 & +EL1K10*EL2K20*EL1K11*EL2K11)
30615 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30616 & +EL1K10*EL2K20*EL1K21*EL2K21)
30617 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30618 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30619 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30620 & +EL1K20*EL2K20*EL1K11*EL2K11)
30621 ELSEIF(MSTP(147).EQ.2) THEN
30623 & -C2*EL1K11*EL2K11
30624 & -C3*EL1K21*EL2K21
30625 & -C4*EL1K11*EL2K21
30626 & +C5*(EL1K11*EL2K11)**2
30627 & +C6*(EL1K21*EL2K21)**2
30628 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30629 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30630 & +(C9+C0)*(EL1K11*EL2K21)**2)
30632 FACQQG=COMFAC*FF*FACQQG
30634 DO 2456 I=MMINA,MMAXA
30635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
30637 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
30638 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
30641 ISIG(NCHN,3-ISDE)=21
30643 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30647 ELSEIF(ISUB.EQ.437) THEN
30648 C...q + q~ -> g + QQ~[3P01]
30649 IF(MSTP(145).EQ.0) THEN
30650 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
30651 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
30653 FA=PARU(1)*AS**3*(128D0/729D0)*
30654 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
30655 IF(MSTP(147).EQ.0) THEN
30657 ELSEIF(MSTP(147).EQ.1) THEN
30658 FACQQG=COMFAC*2D0*FA
30659 ELSEIF(MSTP(147).EQ.3) THEN
30661 ELSEIF(MSTP(147).EQ.4) THEN
30663 ELSEIF(MSTP(147).EQ.5) THEN
30665 ELSEIF(MSTP(147).EQ.6) THEN
30669 DO 2457 I=MMINA,MMAXA
30670 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30671 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
30676 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30679 ELSEIF(ISUB.EQ.438) THEN
30680 C...q + q~ -> g + QQ~[3P11]
30681 IF(MSTP(145).EQ.0) THEN
30682 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
30683 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
30685 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
30690 IF(MSTP(147).EQ.0) THEN
30691 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30692 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30693 ELSEIF(MSTP(147).EQ.1) THEN
30694 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30695 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30696 ELSEIF(MSTP(147).EQ.3) THEN
30697 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30698 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30699 ELSEIF(MSTP(147).EQ.4) THEN
30700 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30701 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30702 ELSEIF(MSTP(147).EQ.5) THEN
30703 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30704 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30705 ELSEIF(MSTP(147).EQ.6) THEN
30706 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30707 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30709 FACQQG=COMFAC*FF*FACQQG
30711 DO 2458 I=MMINA,MMAXA
30712 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30713 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
30718 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30721 ELSEIF(ISUB.EQ.439) THEN
30722 C...q + q~ -> g + QQ~[3P21]
30723 IF(MSTP(145).EQ.0) THEN
30724 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
30725 & ((6D0*SQMQQ**2+SH2)*THUH2
30726 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
30727 & (SQMQQR*SH*THUH2**2)
30729 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
30731 C2=4D0*(SH2+UH2+2D0*SH*THUH)
30732 C3=4D0*(SH2+TH2+2D0*SH*THUH)
30733 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
30740 IF(MSTP(147).EQ.0) THEN
30741 FACQQG=1D0/3D0*(C1*3D0
30742 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30743 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30744 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30745 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30746 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30747 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30748 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30749 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30750 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30751 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30752 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30753 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30754 ELSEIF(MSTP(147).EQ.1) THEN
30756 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30757 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30758 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30759 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30760 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30761 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30762 & +EL1K10*EL2K20*EL1K11*EL2K11)
30763 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30764 & +EL1K10*EL2K20*EL1K21*EL2K21)
30765 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30766 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30767 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30768 & +EL1K20*EL2K20*EL1K11*EL2K11)
30769 ELSEIF(MSTP(147).EQ.2) THEN
30771 & -C2*EL1K11*EL2K11
30772 & -C3*EL1K21*EL2K21
30773 & -C4*EL1K11*EL2K21
30774 & +C5*(EL1K11*EL2K11)**2
30775 & +C6*(EL1K21*EL2K21)**2
30776 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30777 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30778 & +(C9+C0)*(EL1K11*EL2K21)**2)
30780 FACQQG=COMFAC*FF*FACQQG
30782 DO 2459 I=MMINA,MMAXA
30783 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30784 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
30789 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30799 C*********************************************************************
30802 C...Subprocess cross sections for W/Z processes,
30803 C...except that longitudinal WW scattering is in Higgs sector.
30804 C...Auxiliary to PYSIGH.
30806 SUBROUTINE PYSGWZ(NCHN,SIGS)
30808 C...Double precision and integer declarations
30809 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30810 IMPLICIT INTEGER(I-N)
30811 INTEGER PYK,PYCHGE,PYCOMP
30812 C...Parameter statement to help give large particle numbers.
30813 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30814 &KEXCIT=4000000,KDIMEN=5000000)
30816 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30817 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30818 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30819 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
30820 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30821 COMMON/PYINT1/MINT(400),VINT(400)
30822 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30823 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30824 COMMON/PYINT4/MWID(500),WIDS(500,5)
30825 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
30826 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30827 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30828 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30829 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30830 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
30831 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
30832 C...Local arrays and complex numbers
30833 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
30835 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
30837 C...Differential cross section expressions.
30839 IF(ISUB.LE.20) THEN
30841 C...f + fbar -> gamma*/Z0
30843 CALL PYWIDT(23,SH,WDTP,WDTE)
30845 FACZ=4D0*COMFAC*3D0
30848 DO 100 I=MMINA,MMAXA
30849 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30850 EI=KCHG(IABS(I),1)/3D0
30854 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
30856 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
30861 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
30862 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
30863 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
30864 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
30867 ELSEIF(ISUB.EQ.2) THEN
30868 C...f + fbar' -> W+/-
30869 CALL PYWIDT(24,SH,WDTP,WDTE)
30871 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
30872 HP=AEM/(24D0*XW)*SH
30873 DO 120 I=MMIN1,MMAX1
30874 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
30876 DO 110 J=MMIN2,MMAX2
30877 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
30879 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
30880 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
30882 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
30884 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
30889 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
30890 SIGH(NCHN)=HI*FACBW*HF
30894 ELSEIF(ISUB.EQ.15) THEN
30895 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
30896 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30897 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
30901 RADC4=1D0+PYALPS(SQM4)/PARU(1)
30902 DO 130 I=1,MIN(16,MDCY(23,3))
30904 IF(MDME(IDC,1).LT.0) GOTO 130
30906 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
30910 AF=SIGN(1D0,EF+0.1D0)
30912 ELSEIF(I.LE.16) THEN
30914 AF=SIGN(1D0,EF+0.1D0)
30917 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
30918 IF(4D0*RM1.LT.1D0) THEN
30920 IF(I.LE.8) FCOF=3D0*RADC4
30921 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
30923 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
30924 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
30925 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
30926 & AF**2*(1D0-4D0*RM1))*BE34
30930 C...Propagators: as simulated in PYOFSH and as desired
30931 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
30935 CALL PYWIDT(23,SQM4,WDTP,WDTE)
30937 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
30938 HFGG=HFGG*HFAEM*VINT(111)/SQM4
30939 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
30940 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
30941 C...Loop over flavours; consider full gamma/Z structure
30942 DO 140 I=MMINA,MMAXA
30943 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30944 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30945 EI=KCHG(IABS(I),1)/3D0
30952 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
30953 & (VI**2+AI**2)*HFZZ)/HBW4
30956 ELSEIF(ISUB.EQ.16) THEN
30957 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
30958 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30959 C...Propagators: as simulated in PYOFSH and as desired
30960 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
30961 CALL PYWIDT(24,SQM4,WDTP,WDTE)
30962 GMMWC=SQRT(SQM4)*WDTP(0)
30963 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
30964 FACWG=FACWG*HBW4C/HBW4
30965 DO 160 I=MMIN1,MMAX1
30967 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
30968 DO 150 J=MMIN2,MMAX2
30970 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
30971 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
30972 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
30973 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
30974 FCKM=VCKM((IA+1)/2,(JA+1)/2)
30979 SIGH(NCHN)=FACWG*FCKM*WIDSC
30983 ELSEIF(ISUB.EQ.19) THEN
30984 C...f + fbar -> gamma + (gamma*/Z0)
30985 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30986 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
30990 RADC4=1D0+PYALPS(SQM4)/PARU(1)
30991 DO 170 I=1,MIN(16,MDCY(23,3))
30993 IF(MDME(IDC,1).LT.0) GOTO 170
30995 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
30999 AF=SIGN(1D0,EF+0.1D0)
31001 ELSEIF(I.LE.16) THEN
31003 AF=SIGN(1D0,EF+0.1D0)
31006 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31007 IF(4D0*RM1.LT.1D0) THEN
31009 IF(I.LE.8) FCOF=3D0*RADC4
31010 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31012 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31013 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31014 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31015 & AF**2*(1D0-4D0*RM1))*BE34
31019 C...Propagators: as simulated in PYOFSH and as desired
31020 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31024 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31026 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31027 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31028 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31029 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31030 C...Loop over flavours; consider full gamma/Z structure
31031 DO 180 I=MMINA,MMAXA
31032 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31033 EI=KCHG(IABS(I),1)/3D0
31037 IF(IABS(I).LE.10) FCOI=FACA/3D0
31042 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31043 & (VI**2+AI**2)*HFZZ)/HBW4
31046 ELSEIF(ISUB.EQ.20) THEN
31047 C...f + fbar' -> gamma + W+/-
31048 FACGW=COMFAC*0.5D0*AEM**2/XW
31049 C...Propagators: as simulated in PYOFSH and as desired
31050 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31051 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31052 GMMWC=SQRT(SQM4)*WDTP(0)
31053 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31054 FACGW=FACGW*HBW4C/HBW4
31055 C...Anomalous couplings
31056 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31059 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31060 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31061 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31062 & (4D0*SQMW))/(TH+UH)**2
31064 DO 200 I=MMIN1,MMAX1
31066 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31067 DO 190 J=MMIN2,MMAX2
31069 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31070 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31071 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31073 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31074 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31076 FACWR=UH/(TH+UH)-1D0/3D0
31077 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31084 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
31089 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
31094 ELSEIF(ISUB.LE.40) THEN
31095 IF(ISUB.EQ.22) THEN
31096 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
31097 C...Kinematics dependence
31098 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
31099 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
31100 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31106 RADC3=1D0+PYALPS(SQM3)/PARU(1)
31107 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31108 DO 230 I=1,MIN(16,MDCY(23,3))
31110 IF(MDME(IDC,1).LT.0) GOTO 230
31112 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
31113 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
31116 AF=SIGN(1D0,EF+0.1D0)
31118 ELSEIF(I.LE.16) THEN
31120 AF=SIGN(1D0,EF+0.1D0)
31123 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
31124 IF(4D0*RM1.LT.1D0) THEN
31126 IF(I.LE.8) FCOF=3D0*RADC3
31127 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31129 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31130 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31131 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
31132 & AF**2*(1D0-4D0*RM1))*BE34
31135 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31136 IF(4D0*RM1.LT.1D0) THEN
31138 IF(I.LE.8) FCOF=3D0*RADC4
31139 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31141 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31142 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31143 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
31144 & AF**2*(1D0-4D0*RM1))*BE34
31148 C...Propagators: as simulated in PYOFSH and as desired
31149 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
31150 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31154 CALL PYWIDT(23,SQM3,WDTP,WDTE)
31156 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31158 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
31159 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
31160 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
31165 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31167 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31169 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
31170 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
31171 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
31173 C...Loop over flavours; separate left- and right-handed couplings
31174 DO 270 I=MMINA,MMAXA
31175 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
31176 EI=KCHG(IABS(I),1)/3D0
31182 IF(IABS(I).LE.10) FCOI=FACA/3D0
31184 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
31185 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
31186 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
31187 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
31189 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
31190 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
31191 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
31192 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
31197 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
31200 ELSEIF(ISUB.EQ.23) THEN
31201 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
31202 FACZW=COMFAC*0.5D0*(AEM/XW)**2
31203 FACZW=FACZW*WIDS(23,2)
31204 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31205 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
31206 DO 290 I=MMIN1,MMAX1
31208 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
31209 DO 280 J=MMIN2,MMAX2
31211 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
31212 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
31213 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31215 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31217 AI=SIGN(1D0,EI+0.1D0)
31220 AJ=SIGN(1D0,EJ+0.1D0)
31222 IF(VI+AI.GT.0) THEN
31231 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
31233 IF(IA.LE.10) FCOI=FACA/3D0
31238 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
31239 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
31240 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
31241 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
31242 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
31243 & WIDS(24,(5-KCHW)/2)
31244 C***Protect against slightly negative cross sections. (Reason yet to be
31245 C***sorted out. One possibility: addition of width to the W propagator.)
31246 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
31250 ELSEIF(ISUB.EQ.25) THEN
31251 C...f + fbar -> W+ + W-
31252 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
31254 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
31255 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
31256 CALL PYWIDT(24,SQM3,WDTP,WDTE)
31257 GMMW3=SQRT(SQM3)*WDTP(0)
31258 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
31259 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31260 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31261 GMMW4=SQRT(SQM4)*WDTP(0)
31262 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
31263 C...Kinematical functions
31264 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31265 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
31266 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
31267 GT=THUH34+4D0*THUH/TH2
31268 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
31269 GU=THUH34+4D0*THUH/UH2
31270 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
31271 C...Common factors and couplings
31272 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
31273 FACWW=FACWW*WIDS(24,1)
31275 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
31276 CZZ=AEM**2/(32D0*XW**2)*HBWZC
31277 CNG=AEM**2/(4D0*XW)
31278 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
31279 CNN=AEM**2/(16D0*XW**2)
31280 C...Coulomb factor for W+W- pair
31281 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
31282 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
31283 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
31284 IF(COULE.LT.100D0*PMAS(24,2)) THEN
31285 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
31286 & PMAS(24,2)**2)-COULE))
31288 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
31290 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
31291 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
31292 & PMAS(24,2)**2)+COULE))
31294 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
31297 IF(MSTP(40).EQ.1) THEN
31298 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
31299 & MAX(1D-10,2D0*COULP*COULP1))
31300 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
31301 ELSEIF(MSTP(40).EQ.2) THEN
31302 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
31303 COULCP=DCMPLX(0D0,DBLE(COULP))
31304 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
31305 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
31306 & (4D0*COULCP)*LOG(COULCD)
31307 COULCS=DCMPLX(0D0,0D0)
31310 COULXX=(ISTP-0.5)/NSTP
31311 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
31312 & (1D0+COULXX/COULCD))
31314 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
31316 FACCOU=ABS(COULCR)**2
31317 ELSEIF(MSTP(40).EQ.3) THEN
31318 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
31319 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
31320 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
31322 ELSEIF(MSTP(40).EQ.4) THEN
31323 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
31329 C...Loop over allowed flavours
31330 DO 310 I=MMINA,MMAXA
31331 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
31332 EI=KCHG(IABS(I),1)/3D0
31333 AI=SIGN(1D0,EI+0.1D0)
31336 IF(IABS(I).LE.10) FCOI=FACA/3D0
31337 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
31339 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
31340 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
31342 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
31343 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
31346 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31347 BET=SQRT(1D0-4D0*XMW02/SH)
31348 GAT=1D0/SQRT(1D0-BET**2)
31350 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
31351 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
31352 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
31353 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
31354 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
31355 & (1D0-2D0*BET*CTH+BET**2))
31356 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
31357 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
31358 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
31359 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
31360 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
31361 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
31362 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
31369 SIGH(NCHN)=FACWW*FCOI*DSIGWW
31372 ELSEIF(ISUB.EQ.30) THEN
31373 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
31374 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
31376 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31380 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31381 DO 320 I=1,MIN(16,MDCY(23,3))
31383 IF(MDME(IDC,1).LT.0) GOTO 320
31385 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31389 AF=SIGN(1D0,EF+0.1D0)
31391 ELSEIF(I.LE.16) THEN
31393 AF=SIGN(1D0,EF+0.1D0)
31396 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31397 IF(4D0*RM1.LT.1D0) THEN
31399 IF(I.LE.8) FCOF=3D0*RADC4
31400 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31402 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31403 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31404 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31405 & AF**2*(1D0-4D0*RM1))*BE34
31409 C...Propagators: as simulated in PYOFSH and as desired
31410 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31414 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31416 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31417 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31418 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31419 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31420 C...Loop over flavours; consider full gamma/Z structure
31421 DO 340 I=MMINA,MMAXA
31422 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
31423 EI=KCHG(IABS(I),1)/3D0
31426 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
31427 & (VI**2+AI**2)*HFZZ)/HBW4
31429 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
31430 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
31433 ISIG(NCHN,3-ISDE)=21
31439 ELSEIF(ISUB.EQ.31) THEN
31440 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
31441 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
31442 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
31443 C...Propagators: as simulated in PYOFSH and as desired
31444 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31445 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31446 GMMWC=SQRT(SQM4)*WDTP(0)
31447 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31448 FACWQ=FACWQ*HBW4C/HBW4
31449 DO 360 I=MMINA,MMAXA
31450 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
31452 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
31453 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31455 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
31456 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
31459 ISIG(NCHN,3-ISDE)=21
31461 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
31465 ELSEIF(ISUB.EQ.35) THEN
31466 C...f + gamma -> f + (gamma*/Z0)
31467 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
31468 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
31469 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
31470 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
31471 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
31472 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
31474 FZQN=SH2+UH2+2D0*SQM4*TH
31477 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
31478 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31482 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31483 DO 370 I=1,MIN(16,MDCY(23,3))
31485 IF(MDME(IDC,1).LT.0) GOTO 370
31487 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31491 AF=SIGN(1D0,EF+0.1D0)
31493 ELSEIF(I.LE.16) THEN
31495 AF=SIGN(1D0,EF+0.1D0)
31498 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31499 IF(4D0*RM1.LT.1D0) THEN
31501 IF(I.LE.8) FCOF=3D0*RADC4
31502 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31504 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31505 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31506 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31507 & AF**2*(1D0-4D0*RM1))*BE34
31511 C...Propagators: as simulated in PYOFSH and as desired
31512 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31516 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31518 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31519 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31520 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31521 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31522 C...Loop over flavours; consider full gamma/Z structure
31523 DO 390 I=MMINA,MMAXA
31524 IF(I.EQ.0) GOTO 390
31525 EI=KCHG(IABS(I),1)/3D0
31528 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31529 & (VI**2+AI**2)*HFZZ)/HBW4
31530 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
31532 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
31533 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
31536 ISIG(NCHN,3-ISDE)=22
31538 SIGH(NCHN)=FACZQ*FZQN/FZQD
31542 ELSEIF(ISUB.EQ.36) THEN
31543 C...f + gamma -> f' + W+/-
31544 FWQ=COMFAC*AEM**2/(2D0*XW)*
31545 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
31546 C...Propagators: as simulated in PYOFSH and as desired
31547 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31548 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31549 GMMWC=SQRT(SQM4)*WDTP(0)
31550 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31552 DO 410 I=MMINA,MMAXA
31553 IF(I.EQ.0) GOTO 410
31555 EIA=ABS(KCHG(IABS(I),1)/3D0)
31556 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
31557 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
31558 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31560 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
31561 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
31564 ISIG(NCHN,3-ISDE)=22
31566 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
31571 ELSEIF(ISUB.LE.100) THEN
31572 IF(ISUB.EQ.69) THEN
31573 C...gamma + gamma -> W+ + W-
31574 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
31575 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
31576 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
31577 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
31578 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
31586 ELSEIF(ISUB.EQ.70) THEN
31587 C...gamma + W+/- -> Z0 + W+/-
31588 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
31589 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
31590 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
31591 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
31592 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
31593 DO 440 KCHW=1,-1,-2
31595 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
31598 ISIG(NCHN,3-ISDE)=24*KCHW
31600 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
31609 C*********************************************************************
31612 C...Subprocess cross sections for Higgs processes,
31613 C...except Higgs pairs in PYSGSU, but including WW scattering.
31614 C...Auxiliary to PYSIGH.
31616 SUBROUTINE PYSGHG(NCHN,SIGS)
31618 C...Double precision and integer declarations
31619 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31620 IMPLICIT INTEGER(I-N)
31621 INTEGER PYK,PYCHGE,PYCOMP
31622 C...Parameter statement to help give large particle numbers.
31623 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31624 &KEXCIT=4000000,KDIMEN=5000000)
31626 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31627 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31628 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31629 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31630 COMMON/PYINT1/MINT(400),VINT(400)
31631 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31632 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31633 COMMON/PYINT4/MWID(500),WIDS(500,5)
31634 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31635 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31636 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31637 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31638 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31639 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31640 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
31641 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
31642 C...Local arrays and complex variables
31643 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31644 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
31645 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
31647 C...Convert H or A process into equivalent h one
31650 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
31651 KFHIGG=KFPR(ISUB,1)
31653 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
31654 &ISUB.LE.190)) THEN
31656 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
31658 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
31659 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
31660 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
31661 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
31662 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
31663 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
31664 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
31665 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
31666 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
31667 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
31668 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
31669 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
31671 SQMH=PMAS(KFHIGG,1)**2
31672 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
31674 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
31675 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
31676 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
31677 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
31678 IF(MSTP(46).LE.4) THEN
31679 HDTLH=LOG(PMAS(25,1)/PARP(44))
31680 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
31681 HDTNR=-1D0/18D0+HDTLH/6D0
31683 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
31684 HDTLQ=LOG(PARP(45)/PARP(44))
31685 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
31686 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
31689 C...Calculate lowest and next-to-lowest order partial wave amplitudes
31690 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
31694 HDTLS=LOG(SH/PARP(44)**2)
31695 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
31696 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
31697 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
31698 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
31699 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
31700 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
31701 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
31702 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
31704 C...Unitarize partial wave amplitudes with Pade or K-matrix method
31705 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
31706 A00U=A00L/(1D0-A004/A00L)
31707 A20U=A20L/(1D0-A204/A20L)
31708 A11U=A11L/(1D0-A114/A11L)
31710 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
31711 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
31712 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
31716 C...Differential cross section expressions.
31718 IF(ISUB.LE.60) THEN
31720 C...f + fbar -> h0 (or H0, or A0)
31721 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
31723 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31724 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
31726 HP=AEM/(8D0*XW)*SH/SQMW*SH
31727 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31728 DO 100 I=MMINA,MMAXA
31729 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31731 RMQ=PYMRUN(IA,SH)**2/SH
31733 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
31734 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
31736 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
31737 IF(IA.GT.10) IKFI=3
31738 HI=HI*PARU(150+10*IHIGG+IKFI)**2
31739 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
31740 HI=HI/(1D0+RMSS(41))**2
31741 IF(IHIGG.NE.3) THEN
31742 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
31743 & PARU(151+10*IHIGG))**2
31751 SIGH(NCHN)=HI*FACBW*HF
31754 ELSEIF(ISUB.EQ.5) THEN
31756 CALL PYWIDT(25,SH,WDTP,WDTE)
31758 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31759 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
31760 HP=AEM/(8D0*XW)*SH/SQMW*SH
31761 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31763 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
31764 DO 120 I=MMIN1,MMAX1
31765 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31766 DO 110 J=MMIN2,MMAX2
31767 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31768 EI=KCHG(IABS(I),1)/3D0
31771 EJ=KCHG(IABS(J),1)/3D0
31778 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
31782 ELSEIF(ISUB.EQ.8) THEN
31784 CALL PYWIDT(25,SH,WDTP,WDTE)
31786 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31787 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
31788 HP=AEM/(8D0*XW)*SH/SQMW*SH
31789 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31791 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
31792 DO 140 I=MMIN1,MMAX1
31793 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
31794 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
31795 DO 130 J=MMIN2,MMAX2
31796 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
31797 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
31798 IF(EI*EJ.GT.0D0) GOTO 130
31803 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
31807 ELSEIF(ISUB.EQ.24) THEN
31808 C...f + fbar -> Z0 + h0 (or H0, or A0)
31809 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
31810 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
31811 CALL PYWIDT(23,SQM3,WDTP,WDTE)
31812 GMMZ3=SQRT(SQM3)*WDTP(0)
31813 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
31814 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
31815 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
31816 GMMH4=SQRT(SQM4)*WDTP(0)
31817 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
31818 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31819 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
31820 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
31821 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
31822 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
31823 & PARU(154+10*IHIGG)**2
31824 DO 150 I=MMINA,MMAXA
31825 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
31826 EI=KCHG(IABS(I),1)/3D0
31830 IF(IABS(I).LE.10) FCOI=FACA/3D0
31835 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
31838 ELSEIF(ISUB.EQ.26) THEN
31839 C...f + fbar' -> W+/- + h0 (or H0, or A0)
31840 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
31841 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
31842 CALL PYWIDT(24,SQM3,WDTP,WDTE)
31843 GMMW3=SQRT(SQM3)*WDTP(0)
31844 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
31845 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
31846 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
31847 GMMH4=SQRT(SQM4)*WDTP(0)
31848 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
31849 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31850 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
31851 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
31852 FACHW=FACHW*WIDS(KFHIGG,2)
31853 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
31854 & PARU(155+10*IHIGG)**2
31855 DO 170 I=MMIN1,MMAX1
31857 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
31858 DO 160 J=MMIN2,MMAX2
31860 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
31861 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
31862 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31864 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31866 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
31868 IF(IA.LE.10) FCOI=FACA/3D0
31873 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
31877 ELSEIF(ISUB.EQ.32) THEN
31878 C...f + g -> f + h0 (q + g -> q + h0 only)
31879 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
31880 C...H propagator: as simulated in PYOFSH and as desired
31881 SQMHC=PMAS(25,1)**2
31882 GMMHC=PMAS(25,1)*PMAS(25,2)
31883 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
31884 CALL PYWIDT(25,SQM4,WDTP,WDTE)
31885 GMMHCC=SQRT(SQM4)*WDTP(0)
31886 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
31887 FHCQ=FHCQ*HBW4C/HBW4
31888 DO 190 I=MMINA,MMAXA
31890 IF(IA.NE.5) GOTO 190
31891 SQML=PYMRUN(IA,SH)**2
31893 FACHCQ=FHCQ*SQML/SQMW*
31894 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
31895 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
31896 & (SQM4-SQMQ-SH)/SH)
31898 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
31899 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
31902 ISIG(NCHN,3-ISDE)=21
31904 SIGH(NCHN)=FACHCQ*WIDS(25,2)
31909 ELSEIF(ISUB.LE.80) THEN
31910 IF(ISUB.EQ.71) THEN
31911 C...Z0 + Z0 -> Z0 + Z0
31912 IF(SH.LE.4.01D0*SQMZ) GOTO 220
31914 IF(MSTP(46).LE.2) THEN
31915 C...Exact scattering ME:s for on-mass-shell gauge bosons
31916 BE2=1D0-4D0*SQMZ/SH
31917 TH=-0.5D0*SH*BE2*(1D0-CTH)
31918 UH=-0.5D0*SH*BE2*(1D0+CTH)
31919 IF(MAX(TH,UH).GT.-1D0) GOTO 220
31920 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
31921 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
31922 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
31923 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
31924 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
31925 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
31926 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
31927 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
31928 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
31929 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
31930 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
31931 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
31932 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
31933 & (ASHIM+ATHIM+AUHIM)**2)
31934 IF(MSTP(46).EQ.2) FACZZ=0D0
31937 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
31938 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
31939 & ABS(A00U+2D0*A20U)**2
31941 FACZZ=FACZZ*WIDS(23,1)
31943 DO 210 I=MMIN1,MMAX1
31944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
31945 EI=KCHG(IABS(I),1)/3D0
31949 DO 200 J=MMIN2,MMAX2
31950 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
31951 EJ=KCHG(IABS(J),1)/3D0
31959 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
31964 ELSEIF(ISUB.EQ.72) THEN
31965 C...Z0 + Z0 -> W+ + W-
31966 IF(SH.LE.4.01D0*SQMZ) GOTO 250
31968 IF(MSTP(46).LE.2) THEN
31969 C...Exact scattering ME:s for on-mass-shell gauge bosons
31970 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
31972 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
31973 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
31974 IF(MAX(TH,UH).GT.-1D0) GOTO 250
31975 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
31976 & (1D0-2D0*SQMZ/SH)
31977 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
31978 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
31979 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
31980 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
31981 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
31982 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
31983 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
31985 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
31986 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
31987 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
31988 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
31989 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
31991 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
31993 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
31994 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
31995 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
31996 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
31997 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
31998 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
31999 & (ATWIM+AUWIM+A4IM)**2)
32002 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32003 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32004 & ABS(A00U-A20U)**2
32006 FACWW=FACWW*WIDS(24,1)
32008 DO 240 I=MMIN1,MMAX1
32009 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32010 EI=KCHG(IABS(I),1)/3D0
32014 DO 230 J=MMIN2,MMAX2
32015 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32016 EJ=KCHG(IABS(J),1)/3D0
32024 SIGH(NCHN)=FACWW*AVI*AVJ
32029 ELSEIF(ISUB.EQ.73) THEN
32030 C...Z0 + W+/- -> Z0 + W+/-
32031 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32033 IF(MSTP(46).LE.2) THEN
32034 C...Exact scattering ME:s for on-mass-shell gauge bosons
32035 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32036 EP1=1D0-(SQMZ-SQMW)/SH
32037 EP2=1D0+(SQMZ-SQMW)/SH
32038 TH=-0.5D0*SH*BE2*(1D0-CTH)
32039 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32040 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32041 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32042 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32043 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32044 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32045 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32046 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32047 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32049 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32050 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32051 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32052 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32053 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32054 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32055 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32056 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32057 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32058 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32059 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32060 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32062 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32063 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32065 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32066 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32067 IF(MSTP(46).LE.0) FACZW=0D0
32068 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32069 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32070 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32071 & (ASWIM+AUWIM+A4IM)**2)
32074 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32075 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32076 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32078 FACZW=FACZW*WIDS(23,2)
32080 DO 270 I=MMIN1,MMAX1
32081 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
32082 EI=KCHG(IABS(I),1)/3D0
32086 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
32087 DO 260 J=MMIN2,MMAX2
32088 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
32089 EJ=KCHG(IABS(J),1)/3D0
32093 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
32098 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
32103 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
32108 ELSEIF(ISUB.EQ.75) THEN
32109 C...W+ + W- -> gamma + gamma
32111 ELSEIF(ISUB.EQ.76) THEN
32112 C...W+ + W- -> Z0 + Z0
32113 IF(SH.LE.4.01D0*SQMZ) GOTO 310
32115 IF(MSTP(46).LE.2) THEN
32116 C...Exact scattering ME:s for on-mass-shell gauge bosons
32117 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32119 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32120 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32121 IF(MAX(TH,UH).GT.-1D0) GOTO 310
32122 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32123 & (1D0-2D0*SQMZ/SH)
32124 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32125 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32126 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32127 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32128 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32129 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32130 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32132 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32133 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32134 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32135 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32136 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32138 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32140 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
32142 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32143 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32144 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32145 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
32146 & (ATWIM+AUWIM+A4IM)**2)
32149 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32150 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
32151 & ABS(A00U-A20U)**2
32153 FACZZ=FACZZ*WIDS(23,1)
32155 DO 300 I=MMIN1,MMAX1
32156 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
32157 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32158 DO 290 J=MMIN2,MMAX2
32159 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
32160 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32161 IF(EI*EJ.GT.0D0) GOTO 290
32166 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
32171 ELSEIF(ISUB.EQ.77) THEN
32172 C...W+/- + W+/- -> W+/- + W+/-
32173 IF(SH.LE.4.01D0*SQMW) GOTO 340
32175 IF(MSTP(46).LE.2) THEN
32176 C...Exact scattering ME:s for on-mass-shell gauge bosons
32177 BE2=1D0-4D0*SQMW/SH
32181 TH=-0.5D0*SH*BE2*(1D0-CTH)
32182 UH=-0.5D0*SH*BE2*(1D0+CTH)
32183 IF(MAX(TH,UH).GT.-1D0) GOTO 340
32185 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32186 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32188 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32189 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32191 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32192 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32193 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
32196 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
32198 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
32199 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
32200 ATGRE=0.5D0*XW*SH/TH*TGZANG
32202 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
32204 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
32205 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
32206 AUGRE=0.5D0*XW*SH/UH*UGZANG
32208 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
32210 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
32212 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
32214 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
32216 IF(MSTP(46).LE.0) THEN
32221 ELSEIF(MSTP(46).EQ.1) THEN
32222 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
32223 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
32224 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
32225 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
32227 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
32228 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
32229 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
32230 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
32232 AWWA2=AWWARE**2+AWWAIM**2
32233 AWWS2=AWWSRE**2+AWWSIM**2
32236 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32237 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
32238 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
32239 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
32242 DO 330 I=MMIN1,MMAX1
32243 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
32244 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32245 DO 320 J=MMIN2,MMAX2
32246 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
32247 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32248 IF(EI*EJ.LT.0D0) THEN
32250 IF(MSTP(45).EQ.1) GOTO 320
32251 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
32252 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
32255 IF(MSTP(45).EQ.2) GOTO 320
32256 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
32257 IF(MSTP(46).GE.3) FACWW=FWWS
32258 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
32259 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
32265 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
32266 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
32272 ELSEIF(ISUB.LE.120) THEN
32273 IF(ISUB.EQ.102) THEN
32274 C...g + g -> h0 (or H0, or A0)
32275 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32277 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32278 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32279 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32281 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32282 & '(PYSGHG:) did not find Higgs -> g g channel')
32284 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32285 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32286 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32289 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
32294 SIGH(NCHN)=HI*FACBW*HF
32297 ELSEIF(ISUB.EQ.103) THEN
32298 C...gamma + gamma -> h0 (or H0, or A0)
32299 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32301 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32302 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
32303 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
32305 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
32306 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
32308 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32309 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32310 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32313 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
32318 SIGH(NCHN)=HI*FACBW*HF
32321 ELSEIF(ISUB.EQ.110) THEN
32322 C...f + fbar -> gamma + h0
32323 THUH=MAX(TH*UH,SH*CKIN(3)**2)
32324 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
32325 FACHG=FACHG*WIDS(KFHIGG,2)
32326 C...Calculate loop contributions for intermediate gamma* and Z0
32327 CIGTOT=DCMPLX(0D0,0D0)
32328 CIZTOT=DCMPLX(0D0,0D0)
32331 IF(J.LE.2*MSTP(1)) THEN
32334 AJ=SIGN(1D0,EJ+0.1D0)
32336 BALP=SQM4/(2D0*PMAS(J,1))**2
32337 BBET=SH/(2D0*PMAS(J,1))**2
32338 ELSEIF(J.LE.3*MSTP(1)) THEN
32340 JL=2*(J-2*MSTP(1))-1
32341 EJ=KCHG(10+JL,1)/3D0
32342 AJ=SIGN(1D0,EJ+0.1D0)
32344 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
32345 BBET=SH/(2D0*PMAS(10+JL,1))**2
32347 BALP=SQM4/(2D0*PMAS(24,1))**2
32348 BBET=SH/(2D0*PMAS(24,1))**2
32350 BABI=1D0/(BALP-BBET)
32351 IF(BALP.LT.1D0) THEN
32352 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
32355 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
32356 & -DBLE(0.5D0*PARU(1)))
32359 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
32360 IF(BBET.LT.1D0) THEN
32361 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
32364 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
32365 & -DBLE(0.5D0*PARU(1)))
32368 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
32369 IF(J.LE.3*MSTP(1)) THEN
32370 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
32371 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
32372 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
32373 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
32376 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
32377 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
32378 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
32379 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
32380 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
32381 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
32385 CIGTOT=CIGTOT/DBLE(SH)
32386 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
32387 C...Loop over initial flavours
32388 DO 380 I=MMINA,MMAXA
32389 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
32390 EI=KCHG(IABS(I),1)/3D0
32394 IF(IABS(I).LE.10) FCOI=FACA/3D0
32399 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
32400 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
32403 ELSEIF(ISUB.EQ.111) THEN
32404 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
32405 IF(MSTP(38).NE.0) THEN
32406 C...Simple case: only do gg <-> h exactly.
32407 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32409 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32410 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32411 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32413 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32414 & '(PYSGHG:) did not find Higgs -> g g channel')
32415 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
32416 & (TH**2+UH**2)/(SH*SQM4)
32417 C...Propagators: as simulated in PYOFSH and as desired
32418 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32419 GMMHC=SQRT(SQM4)*WDTP(0)
32420 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32421 & ((SQM4-SQMH)**2+GMMHC**2)
32422 FACGH=FACGH*HBW4C/HBW4
32424 C...Messy case: do full loop integrals
32427 DO 390 I=1,2*MSTP(1)
32431 CALL PYWAUX(1,EPSS,W1SR,W1SI)
32432 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32433 CALL PYWAUX(2,EPSS,W2SR,W2SI)
32434 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32435 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
32436 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
32437 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
32438 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
32440 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
32441 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
32442 FACGH=FACGH*WIDS(25,2)
32444 DO 400 I=MMINA,MMAXA
32445 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32446 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
32454 ELSEIF(ISUB.EQ.112) THEN
32455 C...f + g -> f + h0 (q + g -> q + h0 only)
32456 IF(MSTP(38).NE.0) THEN
32457 C...Simple case: only do gg <-> h exactly.
32458 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32460 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32461 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32462 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32464 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32465 & '(PYSGHG:) did not find Higgs -> g g channel')
32466 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
32467 & (SH**2+UH**2)/(-TH*SQM4)
32468 C...Propagators: as simulated in PYOFSH and as desired
32469 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32470 GMMHC=SQRT(SQM4)*WDTP(0)
32471 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32472 & ((SQM4-SQMH)**2+GMMHC**2)
32473 FACQH=FACQH*HBW4C/HBW4
32475 C...Messy case: do full loop integrals
32478 DO 410 I=1,2*MSTP(1)
32482 CALL PYWAUX(1,EPST,W1TR,W1TI)
32483 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32484 CALL PYWAUX(2,EPST,W2TR,W2TI)
32485 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32486 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
32487 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
32488 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
32489 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
32491 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
32492 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
32493 FACQH=FACQH*WIDS(25,2)
32495 DO 430 I=MMINA,MMAXA
32496 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
32498 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
32499 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
32502 ISIG(NCHN,3-ISDE)=21
32508 ELSEIF(ISUB.EQ.113) THEN
32509 C...g + g -> g + h0
32510 IF(MSTP(38).NE.0) THEN
32511 C...Simple case: only do gg <-> h exactly.
32512 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32514 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32515 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32516 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32518 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32519 & '(PYSGHG:) did not find Higgs -> g g channel')
32520 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
32521 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
32522 C...Propagators: as simulated in PYOFSH and as desired
32523 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32524 GMMHC=SQRT(SQM4)*WDTP(0)
32525 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32526 & ((SQM4-SQMH)**2+GMMHC**2)
32527 FACGH=FACGH*HBW4C/HBW4
32529 C...Messy case: do full loop integrals
32538 DO 440 I=1,2*MSTP(1)
32544 IF(EPSH.LT.1D-6) GOTO 440
32545 CALL PYWAUX(1,EPSS,W1SR,W1SI)
32546 CALL PYWAUX(1,EPST,W1TR,W1TI)
32547 CALL PYWAUX(1,EPSU,W1UR,W1UI)
32548 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32549 CALL PYWAUX(2,EPSS,W2SR,W2SI)
32550 CALL PYWAUX(2,EPST,W2TR,W2TI)
32551 CALL PYWAUX(2,EPSU,W2UR,W2UI)
32552 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32553 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
32554 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
32555 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
32556 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
32557 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
32558 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
32559 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
32560 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
32561 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
32562 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
32563 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
32564 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
32565 W3STUR=YHSTUR-Y3STUR-Y3UTSR
32566 W3STUI=YHSTUI-Y3STUI-Y3UTSI
32567 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
32568 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
32569 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
32570 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
32571 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
32572 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
32573 W3USTR=YHUSTR-Y3USTR-Y3TSUR
32574 W3USTI=YHUSTI-Y3USTI-Y3TSUI
32575 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
32576 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
32577 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
32578 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
32579 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
32580 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
32581 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
32582 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
32583 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
32584 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
32585 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
32586 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
32587 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
32588 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
32589 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
32590 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
32591 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
32592 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
32593 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
32594 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
32595 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
32596 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
32597 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
32598 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
32599 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
32600 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
32601 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
32602 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
32603 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
32604 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
32605 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
32606 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
32607 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
32608 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
32609 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
32610 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
32611 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
32612 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
32613 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
32614 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
32615 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
32616 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
32617 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
32618 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
32619 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
32620 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
32621 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
32622 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
32623 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
32624 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
32625 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
32626 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
32627 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
32628 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
32629 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
32630 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
32631 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
32632 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
32633 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
32634 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
32635 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
32636 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
32637 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32638 & (W2SR-W2HR+W3STUR))
32639 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
32640 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32641 & (W2TR-W2HR+W3TUSR))
32642 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
32643 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32644 & (W2UR-W2HR+W3USTR))
32645 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
32646 A2STUR=A2STUR+B2STUR+B2SUTR
32647 A2STUI=A2STUI+B2STUI+B2SUTI
32648 A2USTR=A2USTR+B2USTR+B2UTSR
32649 A2USTI=A2USTI+B2USTI+B2UTSI
32650 A2TUSR=A2TUSR+B2TUSR+B2TSUR
32651 A2TUSI=A2TUSI+B2TUSI+B2TSUI
32652 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
32653 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
32655 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
32656 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
32657 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
32658 FACGH=FACGH*WIDS(25,2)
32660 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
32669 ELSEIF(ISUB.LE.170) THEN
32670 IF(ISUB.EQ.121) THEN
32671 C...g + g -> Q + Qbar + h0
32672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
32675 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
32676 & (0.5D0*PMF/PMAS(24,1))**2
32678 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
32680 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32682 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32683 IF(IA.GT.10) IKFI=3
32684 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
32685 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32686 FACQQH=FACQQH/(1D0+RMSS(41))**2
32687 IF(IHIGG.NE.3) THEN
32688 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32689 & PARU(151+10*IHIGG))**2
32693 CALL PYQQBH(WTQQBH)
32694 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32696 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32697 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32698 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32704 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
32707 ELSEIF(ISUB.EQ.122) THEN
32708 C...q + qbar -> Q + Qbar + h0
32711 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
32712 & (0.5D0*PMF/PMAS(24,1))**2
32714 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
32716 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32718 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32719 IF(IA.GT.10) IKFI=3
32720 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
32721 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32722 FACQQH=FACQQH/(1D0+RMSS(41))**2
32723 IF(IHIGG.NE.3) THEN
32724 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32725 & PARU(151+10*IHIGG))**2
32729 CALL PYQQBH(WTQQBH)
32730 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32732 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32733 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32734 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32736 DO 470 I=MMINA,MMAXA
32737 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32738 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
32743 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
32746 ELSEIF(ISUB.EQ.123) THEN
32747 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
32749 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
32750 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
32751 & PARU(154+10*IHIGG)**2
32752 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
32753 & (VINT(216)-VINT(209)**2))**2
32754 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
32755 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
32756 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32758 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32759 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32760 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32762 DO 490 I=MMIN1,MMAX1
32763 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
32765 DO 480 J=MMIN2,MMAX2
32766 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
32768 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
32769 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
32771 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
32772 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
32774 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
32775 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
32780 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
32784 ELSEIF(ISUB.EQ.124) THEN
32785 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
32787 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
32788 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
32789 & PARU(155+10*IHIGG)**2
32790 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
32791 & (VINT(216)-VINT(209)**2))**2
32792 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
32793 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32795 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32796 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32797 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32799 DO 510 I=MMIN1,MMAX1
32800 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
32801 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32802 DO 500 J=MMIN2,MMAX2
32803 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
32804 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32805 IF(EI*EJ.GT.0D0) GOTO 500
32806 FACLR=VINT(180+I)*VINT(180+J)
32811 SIGH(NCHN)=FACLR*FACWW*FACBW
32815 ELSEIF(ISUB.EQ.143) THEN
32816 C...f + fbar' -> H+/-
32817 SQMHC=PMAS(37,1)**2
32818 CALL PYWIDT(37,SH,WDTP,WDTE)
32820 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
32821 HP=AEM/(8D0*XW)*SH/SQMW*SH
32822 DO 530 I=MMIN1,MMAX1
32823 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
32825 IM=(MOD(IA,10)+1)/2
32826 DO 520 J=MMIN2,MMAX2
32827 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
32829 JM=(MOD(JA,10)+1)/2
32830 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
32831 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32833 IF(MOD(IA,2).EQ.0) THEN
32840 RML=PYMRUN(IL,SH)**2/SH
32841 RMU=PYMRUN(IU,SH)**2/SH
32842 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
32843 IF(IA.LE.10) HI=HI*FACA/3D0
32844 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32845 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
32850 SIGH(NCHN)=HI*FACBW*HF
32854 ELSEIF(ISUB.EQ.161) THEN
32855 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
32856 C...(choice of only b and t to avoid kinematics problems)
32857 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
32858 C...H propagator: as simulated in PYOFSH and as desired
32859 SQMHC=PMAS(37,1)**2
32860 GMMHC=PMAS(37,1)*PMAS(37,2)
32861 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32862 CALL PYWIDT(37,SQM4,WDTP,WDTE)
32863 GMMHCC=SQRT(SQM4)*WDTP(0)
32864 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32865 FHCQ=FHCQ*HBW4C/HBW4
32867 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
32868 DO 550 I=MMINA,MMAXA
32870 IF(IA.NE.5) GOTO 550
32871 SQML=PYMRUN(IA,Q2RM)**2
32873 SQMQ=PYMRUN(IUA,Q2RM)**2
32874 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
32875 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32876 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
32877 & (SQMHC-SQMQ-SH)/SH)
32878 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32880 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
32881 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
32884 ISIG(NCHN,3-ISDE)=21
32886 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
32887 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
32892 ELSEIF(ISUB.LE.402) THEN
32893 IF(ISUB.EQ.401) THEN
32894 C... g + g -> t + bbar + H-
32895 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
32898 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32900 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
32901 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32907 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
32908 c Since we don't know yet if H+ or H-, assume H+
32909 c when calculating suppression due to closed channels.
32910 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
32911 IF(ABS(WIDS(37,2)-WIDS(37,3))
32912 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
32913 & ABS(WIDS(6,2)-WIDS(6,3))
32914 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
32915 WRITE(*,*)'Error: Process 401 cannot handle different'
32916 WRITE(*,*)'decays for H+ and H- or t and tbar.'
32917 WRITE(*,*)'Execution stopped.'
32922 ELSEIF(ISUB.EQ.402) THEN
32923 C... q + qbar -> t + bbar + H-
32926 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32928 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
32929 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32931 DO 570 I=MMINA,MMAXA
32932 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32933 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
32938 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
32939 c Since we don't know yet if H+ or H-, assume H+
32940 c when calculating suppression due to closed channels.
32941 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
32942 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
32944 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
32946 WRITE(*,*)'Error: Process 402 cannot handle different'
32947 WRITE(*,*)'decays for H+ and H- or t and tbar.'
32948 WRITE(*,*)'Execution stopped.'
32958 C*********************************************************************
32961 C...Subprocess cross sections for SUSY processes,
32962 C...including Higgs pair production.
32963 C...Auxiliary to PYSIGH.
32965 SUBROUTINE PYSGSU(NCHN,SIGS)
32967 C...Double precision and integer declarations
32968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32969 IMPLICIT INTEGER(I-N)
32970 INTEGER PYK,PYCHGE,PYCOMP
32971 C...Parameter statement to help give large particle numbers.
32972 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32973 &KEXCIT=4000000,KDIMEN=5000000)
32975 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32976 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32978 COMMON/PYINT1/MINT(400),VINT(400)
32979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32980 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32981 COMMON/PYINT4/MWID(500),WIDS(500,5)
32982 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32983 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32984 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32985 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32986 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32987 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32988 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32989 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
32990 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
32991 C...Local arrays and complex variables
32992 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32993 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
32994 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
32995 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
32998 C...Z and W width, combinations of weak mixing angle
33002 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33004 C...Convert almost equivalent SUSY processes into each other
33005 C...Extract differences in flavours and couplings
33007 C...Sleptons and sneutrinos
33008 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33009 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33012 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33013 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33016 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33017 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33019 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33020 IF(ISUB.EQ.210) THEN
33022 ELSEIF(ISUB.EQ.211) THEN
33024 ELSEIF(ISUB.EQ.212) THEN
33028 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33029 IF(ISUB.EQ.213) THEN
33030 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33032 ELSEIF(ISUB.EQ.214) THEN
33039 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33040 IF(ISUB.EQ.216) THEN
33043 ELSEIF(ISUB.EQ.217) THEN
33046 ELSEIF(ISUB.EQ.218) THEN
33049 ELSEIF(ISUB.EQ.219) THEN
33052 ELSEIF(ISUB.EQ.220) THEN
33055 ELSEIF(ISUB.EQ.221) THEN
33058 ELSEIF(ISUB.EQ.222) THEN
33061 ELSEIF(ISUB.EQ.223) THEN
33064 ELSEIF(ISUB.EQ.224) THEN
33067 ELSEIF(ISUB.EQ.225) THEN
33074 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33075 IF(ISUB.EQ.226) THEN
33078 ELSEIF(ISUB.EQ.227) THEN
33081 ELSEIF(ISUB.EQ.228) THEN
33087 C...Neutralino + chargino
33088 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
33089 IF(ISUB.EQ.229) THEN
33092 ELSEIF(ISUB.EQ.230) THEN
33095 ELSEIF(ISUB.EQ.231) THEN
33098 ELSEIF(ISUB.EQ.232) THEN
33101 ELSEIF(ISUB.EQ.233) THEN
33104 ELSEIF(ISUB.EQ.234) THEN
33107 ELSEIF(ISUB.EQ.235) THEN
33110 ELSEIF(ISUB.EQ.236) THEN
33116 C...Gluino + neutralino
33117 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
33118 IF(ISUB.EQ.237) THEN
33120 ELSEIF(ISUB.EQ.238) THEN
33122 ELSEIF(ISUB.EQ.239) THEN
33124 ELSEIF(ISUB.EQ.240) THEN
33129 C...Gluino + chargino
33130 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
33131 IF(ISUB.EQ.241) THEN
33133 ELSEIF(ISUB.EQ.242) THEN
33138 C...Squark + neutralino
33139 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
33141 IF(MOD(ISUB,2).NE.0) ILR=1
33142 IF(ISUB.LE.247) THEN
33144 ELSEIF(ISUB.LE.249) THEN
33146 ELSEIF(ISUB.LE.251) THEN
33148 ELSEIF(ISUB.LE.253) THEN
33154 C...Squark + chargino
33155 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
33156 IF(ISUB.LE.255) THEN
33158 ELSEIF(ISUB.LE.257) THEN
33161 IF(MOD(ISUB,2).EQ.0) THEN
33169 C...Squark + gluino
33170 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
33175 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
33177 IF(ISUB.EQ.262) ILR=1
33179 ELSEIF(ISUB.EQ.265) THEN
33183 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
33185 IF(ISUB.LE.273) THEN
33186 IF(ISUB.EQ.273) ILR=1
33189 ELSEIF(ISUB.LE.276) THEN
33190 IF(ISUB.EQ.276) ILR=1
33193 ELSEIF(ISUB.LE.278) THEN
33194 IF(ISUB.EQ.278) ILR=1
33198 IF(ISUB.EQ.280) ILR=1
33203 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
33205 IF(ISUB.LE.283) THEN
33206 IF(ISUB.EQ.283) ILR=1
33209 ELSEIF(ISUB.LE.286) THEN
33210 IF(ISUB.EQ.286) ILR=1
33213 ELSEIF(ISUB.LE.288) THEN
33214 IF(ISUB.EQ.288) ILR=1
33217 ELSEIF(ISUB.LE.290) THEN
33218 IF(ISUB.EQ.290) ILR=1
33221 ELSEIF(ISUB.LE.293) THEN
33222 IF(ISUB.EQ.293) ILR=1
33225 ELSEIF(ISUB.EQ.296) THEN
33229 C...Squark + gluino
33230 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
33235 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
33236 IF(ISUB.EQ.297) THEN
33237 RKF=.5D0*PARU(195)**2
33238 ELSEIF(ISUB.EQ.298) THEN
33239 RKF=.5D0*(1D0-PARU(195)**2)
33243 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
33244 IF(ISUB.EQ.299) THEN
33247 ELSEIF(ISUB.EQ.300) THEN
33253 ELSEIF(ISUB.EQ.301) THEN
33259 C...Supersymmetric processes - all of type 2 -> 2 :
33260 C...correct final-state Breit-Wigners from fixed to running width.
33261 IF(MSTP(42).GT.0) THEN
33263 KFLW=KFPR(ISUBSV,I)
33265 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
33266 IF(I.EQ.1) SQMI=SQM3
33267 IF(I.EQ.2) SQMI=SQM4
33268 SQMS=PMAS(KCW,1)**2
33269 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
33270 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
33271 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
33272 GMMI=SQRT(SQMI)*WDTP(0)
33273 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
33274 COMFAC=COMFAC*(HBWI/HBWS)
33278 C...Differential cross section expressions.
33280 IF(ISUB.LE.210) THEN
33281 IF(ISUB.EQ.201) THEN
33282 C...f + fbar -> e_L + e_Lbar
33283 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33284 DO 130 I=MMIN1,MMAX1
33286 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
33288 TT3I=SIGN(1D0,EI+1D-6)/2D0
33292 C...Color factor for e+ e-
33293 IF(IA.GE.11) FCOL=3D0
33294 IF(ISUBSV.EQ.301) THEN
33297 ELSEIF(ILR.EQ.1) THEN
33298 A1=SFMIX(KFID,3)**2
33299 A2=SFMIX(KFID,4)**2
33300 ELSEIF(ILR.EQ.0) THEN
33301 A1=SFMIX(KFID,1)**2
33302 A2=SFMIX(KFID,2)**2
33304 XLQ=(TT3J-EJ*XW)*A1
33308 TAA=(EI*EJ)**2*(POLL+POLR)
33309 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
33310 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
33311 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
33312 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
33316 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
33322 DK=1D0/(TH-SMZ(II)**2)
33323 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
33325 FREK=FAC2*TANW*EI*ZMIX(II,1)
33326 TNN1=TNN1+FLEK**2*DK
33327 TNN2=TNN2+FREK**2*DK
33329 DL=1D0/(TH-SMZ(JJ)**2)
33330 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
33332 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
33333 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
33336 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
33337 & A2**2*TNN2**2*POLR)
33338 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
33339 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
33340 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
33341 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
33342 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
33345 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
33348 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
33349 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
33350 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
33355 SIGH(NCHN)=FACQQ1+FACQQ2
33358 ELSEIF(ISUB.EQ.203) THEN
33359 C...f + fbar -> e_L + e_Rbar
33360 DO 160 I=MMIN1,MMAX1
33362 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
33363 EI=KCHG(IABS(I),1)/3D0
33364 TT3I=SIGN(1D0,EI)/2D0
33368 C...Color factor for e+ e-
33369 IF(IA.GE.11) FCOL=3D0
33370 A1=SFMIX(KFID,1)**2
33371 A2=SFMIX(KFID,2)**2
33376 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
33377 & /XW**2/XW1**2*A1*A2
33378 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
33383 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
33389 DK=1D0/(TH-SMZ(II)**2)
33390 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
33392 FREK=FAC2*TANW*EI*ZMIX(II,1)
33393 TNN1=TNN1+FLEK**2*DK
33394 TNN2=TNN2+FREK**2*DK
33396 DL=1D0/(TH-SMZ(JJ)**2)
33397 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
33399 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
33400 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
33403 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
33404 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
33405 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
33406 TZN=(UH*TH-SQM3*SQM4)*A1*A2
33407 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
33408 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
33411 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
33412 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
33413 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
33419 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33420 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
33425 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
33426 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33429 ELSEIF(ISUB.EQ.210) THEN
33430 C...q + qbar' -> W*- > ~l_L + ~nu_L
33431 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
33432 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
33433 DO 180 I=MMIN1,MMAX1
33435 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
33436 DO 170 J=MMIN2,MMAX2
33438 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
33439 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
33441 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33442 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33444 IF(KCHSUM.LT.0) KCHW=3
33449 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
33450 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
33451 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33453 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
33454 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33456 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
33461 ELSEIF(ISUB.LE.220) THEN
33462 IF(ISUB.EQ.213) THEN
33463 C...f + fbar -> ~nu_L + ~nu_Lbar
33464 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
33465 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33466 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33468 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33471 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
33474 DO 190 I=MMIN1,MMAX1
33476 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
33479 C...Color factor for e+ e-
33480 IF(IA.GE.11) FCOL=3D0
33481 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
33485 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
33486 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
33489 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
33491 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
33497 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
33498 & *AEM**2*FCOL/3D0/XW**2
33501 ELSEIF(ISUB.EQ.216) THEN
33502 C...q + qbar -> ~chi0_1 + ~chi0_1
33503 IF(IZID1.EQ.IZID2) THEN
33504 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33506 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33507 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33509 FACXX=COMFAC*AEM**2/3D0/XW**2
33510 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
33513 WU2 = (UH-ZM12)*(UH-ZM22)
33514 WT2 = (TH-ZM12)*(TH-ZM22)
33515 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
33516 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
33517 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
33519 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
33520 IF(IZID2.NE.IZID1) THEN
33521 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
33524 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
33525 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
33527 DO 210 I=MMINA,MMAXA
33528 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
33529 EI=KCHG(IABS(I),1)/3D0
33530 T3I=SIGN(1D0,EI+1D-6)/2D0
33531 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
33532 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
33533 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
33534 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
33535 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
33536 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
33537 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
33539 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
33540 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
33541 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
33543 IF(IABS(I).GE.11) FCOL=3D0
33544 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
33545 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
33546 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
33547 & QRL*DCONJG(QRR)*POLR)*WS2
33552 SIGH(NCHN)=FACXX*FACGG1*FCOL
33556 ELSEIF(ISUB.LE.230) THEN
33557 IF(ISUB.EQ.226) THEN
33558 C...f + fbar -> ~chi+_1 + ~chi-_1
33559 FACXX=COMFAC*AEM**2/3D0
33562 WU2 = (UH-ZM12)*(UH-ZM22)
33563 WT2 = (TH-ZM12)*(TH-ZM22)
33564 WS2 = SMW(IZID1)*SMW(IZID2)*SH
33565 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
33566 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
33568 IF(IZID1.EQ.IZID2) DIFF=1D0
33570 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
33571 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
33572 IF(IZID2.NE.IZID1) THEN
33573 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
33574 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
33577 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
33578 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
33579 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
33580 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
33581 DO 230 I=MMINA,MMAXA
33582 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
33583 EI=KCHG(IABS(I),1)/3D0
33584 T3I=SIGN(1D0,EI+1D-6)/2D0
33585 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
33586 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
33587 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
33588 IF(MOD(I,2).EQ.0) THEN
33589 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
33590 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
33591 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
33592 & DCMPLX(T3I/XW/(TH-XML2))
33594 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
33595 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
33596 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
33597 & DCMPLX(T3I/XW/(TH-XML2))
33600 IF(IABS(I).GE.11) FCOL=3D0
33601 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
33602 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
33603 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
33604 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
33609 IF(IZID1.EQ.IZID2) THEN
33610 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33612 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
33613 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33618 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33619 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
33623 ELSEIF(ISUB.EQ.229) THEN
33624 C...q + qbar' -> ~chi0_1 + ~chi+-_1
33625 FACXX=COMFAC*AEM**2/6D0/XW**2
33628 WU2 = (UH-ZM12)*(UH-ZM22)
33629 WT2 = (TH-ZM12)*(TH-ZM22)
33630 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
33631 RT2I = 1D0/SQRT(2D0)
33632 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
33633 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
33635 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
33636 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
33639 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
33641 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
33642 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
33643 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
33644 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
33646 DO 270 I=MMIN1,MMAX1
33648 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
33650 T3I=SIGN(1D0,EI+1D-6)/2D0
33651 DO 260 J=MMIN2,MMAX2
33653 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
33654 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
33656 T3J=SIGN(1D0,EJ+1D-6)/2D0
33658 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33659 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33661 IF(KCHSUM.LT.0) KCHW=3
33662 IF(MOD(IA,2).EQ.0) THEN
33663 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
33664 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
33665 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
33666 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
33667 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
33668 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
33671 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
33672 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
33673 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
33674 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
33675 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
33676 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
33679 ZINTR=DBLE(QLR*DCONJG(QLL))
33680 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
33686 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33687 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33692 ELSEIF(ISUB.LE.240) THEN
33693 IF(ISUB.EQ.237) THEN
33694 C...q + qbar -> gluino + ~chi0_1
33695 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33696 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33698 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
33701 DO 280 I=MMINA,MMAXA
33702 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
33703 EI=KCHG(IABS(I),1)/3D0
33705 XLQC = -TANW*EI*ZMIX(IZID,1)
33706 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
33707 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
33710 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
33711 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
33712 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
33713 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
33714 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
33715 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
33716 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
33717 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
33718 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
33719 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
33724 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
33728 ELSEIF(ISUB.LE.250) THEN
33729 IF(ISUB.EQ.241) THEN
33730 C...q + qbar' -> ~chi+-_1 + gluino
33731 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
33734 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
33735 FAC0=UMIX(IZID,1)**2
33736 FAC1=VMIX(IZID,1)**2
33737 DO 300 I=MMIN1,MMAX1
33739 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
33740 DO 290 J=MMIN2,MMAX2
33742 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
33743 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
33745 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33746 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33748 IF(KCHSUM.LT.0) KCHW=3
33749 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
33750 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
33751 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
33752 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
33753 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
33754 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
33755 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
33756 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
33757 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
33758 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
33759 & SH/(TH-XMU2)/(UH-XMD2))/2D0
33764 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
33765 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33766 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33770 ELSEIF(ISUB.EQ.243) THEN
33771 C...q + qbar -> gluino + gluino
33772 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33775 DO 310 I=MMINA,MMAXA
33776 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33777 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33779 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
33780 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
33781 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
33782 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
33783 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
33784 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
33785 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
33786 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
33787 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
33788 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
33789 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
33790 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
33794 C...1/2 for identical particles
33795 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
33798 ELSEIF(ISUB.EQ.244) THEN
33799 C...g + g -> gluino + gluino
33800 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33803 FACQQ1=COMFAC*AS**2*9D0/4D0*(
33804 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
33805 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
33806 FACQQ2=COMFAC*AS**2*9D0/4D0*(
33807 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
33808 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
33809 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
33810 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
33811 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
33816 SIGH(NCHN)=FACQQ1/2D0
33821 SIGH(NCHN)=FACQQ2/2D0
33826 SIGH(NCHN)=FACQQ3/2D0
33829 ELSEIF(ISUB.EQ.246) THEN
33830 C...g + q_j -> ~chi0_1 + ~q_j
33831 FAC0=COMFAC*AS*AEM/6D0/XW
33834 FACZQ0=FAC0*( (ZM2-TH)/SH +
33835 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
33836 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
33837 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33838 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
33839 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
33840 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33841 EI=KCHG(IABS(I),1)/3D0
33843 XRQZ = -TANW*EI*ZMIX(IZID,1)
33844 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
33845 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
33847 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
33849 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
33855 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33856 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33859 ISIG(NCHN,3-ISDE)=21
33861 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33862 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33867 ELSEIF(ISUB.LE.260) THEN
33868 IF(ISUB.EQ.254) THEN
33869 C...g + q_j -> ~chi1_1 + ~q_i
33870 FAC0=COMFAC*AS*AEM/12D0/XW
33875 FACZQ0=FAC0*( (ZM2-TH)/SH +
33876 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
33877 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
33878 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
33879 IF(MOD(KFNSQ1,2).EQ.0) THEN
33886 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
33887 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
33888 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33890 IF(MOD(IA,2).EQ.0) THEN
33895 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
33899 IF(I.LT.0) KCHWQ=5-KCHW
33901 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33902 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33905 ISIG(NCHN,3-ISDE)=21
33907 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33908 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
33912 ELSEIF(ISUB.EQ.258) THEN
33913 C...g + q_j -> gluino + ~q_i
33920 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
33921 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
33922 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
33923 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
33924 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
33926 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
33927 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
33928 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
33930 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
33931 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
33932 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33933 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
33934 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
33935 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
33938 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33939 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33941 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
33942 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
33945 ISIG(NCHN,3-ISDE)=21
33947 SIGH(NCHN)=FACQG1*FACSEL
33950 ISIG(NCHN,3-ISDE)=21
33952 SIGH(NCHN)=FACQG2*FACSEL
33957 ELSEIF(ISUB.LE.270) THEN
33958 IF(ISUB.EQ.261) THEN
33959 C...q_i + q_ibar -> ~t_1 + ~t_1bar
33960 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
33961 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33962 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33964 DO 390 I=MMIN1,MMAX1
33966 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
33967 IF(IA.GE.11.AND.IA.LE.18) THEN
33969 EJ=KCHG(KFNSQ,1)/3D0
33970 T3I=SIGN(1D0,EI)/2D0
33971 T3J=SIGN(1D0,EJ)/2D0
33972 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
33973 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
33974 XLF=2D0*(T3I-EI*XW)
33976 TAA=0.5D0*(EI*EJ)**2
33977 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
33978 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
33979 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
33980 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
33981 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
33987 SIGH(NCHN)=FACQQ1*FAC0
33990 ELSEIF(ISUB.EQ.263) THEN
33991 C...f + fbar -> ~t1 + ~t2bar
33992 DO 400 I=MMIN1,MMAX1
33994 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33995 EI=KCHG(IABS(I),1)/3D0
33996 TT3I=SIGN(1D0,EI)/2D0
34000 C...Color factor for e+ e-
34001 IF(IA.GE.11) FCOL=3D0
34002 XLQ=2D0*(TT3J-EJ*XW)
34004 XLF=2D0*(TT3I-EI*XW)
34006 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34007 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34008 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34009 C...Factor of 2 for t1 t2bar + t2 t1bar
34010 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34011 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34016 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34017 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34022 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34023 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34026 ELSEIF(ISUB.EQ.264) THEN
34027 C...g + g -> ~t_1 + ~t_1bar
34030 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34031 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34032 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34033 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34034 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34048 ELSEIF(ISUB.LE.280) THEN
34049 IF(ISUB.EQ.271) THEN
34050 C...q + q' -> ~q + ~q' (~g exchange)
34051 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34060 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34061 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34064 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34065 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34066 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34069 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34070 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34071 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34072 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34074 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34077 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34078 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
34080 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
34081 IF(I*J.LT.0) GOTO 420
34086 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34087 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34090 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
34091 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34093 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
34094 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34095 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34102 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
34103 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34105 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
34106 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34107 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34113 ELSEIF(ISUB.EQ.274) THEN
34114 C...q + qbar' -> ~q + ~qbar'
34115 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34119 C...Mrenna...Normalization.and.1/XMT
34120 FACQQ1=COMFAC*AS**2*2D0/9D0*(
34121 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
34122 FACQQB=COMFAC*AS**2*4D0/9D0*(
34123 & (UH*TH-SQM3*SQM4)/SH2 )
34124 FACQQI=-COMFAC*AS**2*4D0/27D0*(
34125 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
34126 FACQQB=FACQQB+FACQQ1+FACQQI
34128 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
34131 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34132 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34133 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
34134 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
34136 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
34139 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34140 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
34142 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
34143 IF(I*J.GT.0) GOTO 440
34148 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34149 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
34150 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
34151 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34155 ELSEIF(ISUB.EQ.277) THEN
34156 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
34157 C...if i .eq. j covered in 274
34158 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
34159 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34161 DO 460 I=MMIN1,MMAX1
34163 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
34164 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
34165 IF(IA.EQ.KFNSQ) GOTO 460
34166 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
34168 EJ=KCHG(KFNSQ,1)/3D0
34170 T3I=SIGN(1D0,EI)/2D0
34172 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
34173 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
34175 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
34176 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
34178 XLF=2D0*(T3I-EI*XW)
34185 TAA=0.5D0*(EI*EJ)**2
34186 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34187 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34188 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34189 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34190 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34191 ELSEIF(IA.LE.6) THEN
34192 FAC0=AS**2*8D0/9D0/2D0
34198 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34201 ELSEIF(ISUB.EQ.279) THEN
34202 C...g + g -> ~q_j + ~q_jbar
34205 C...5=RKF because ~t ~tbar treated separately
34206 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
34207 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34208 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34209 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
34214 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34219 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34229 C*********************************************************************
34232 C...Subprocess cross sections for Technicolor processes.
34233 C...Auxiliary to PYSIGH.
34235 SUBROUTINE PYSGTC(NCHN,SIGS)
34237 C...Double precision and integer declarations
34238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34239 IMPLICIT INTEGER(I-N)
34240 INTEGER PYK,PYCHGE,PYCOMP
34241 C...Parameter statement to help give large particle numbers.
34242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34243 &KEXCIT=4000000,KDIMEN=5000000)
34245 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34246 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34247 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34248 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34249 COMMON/PYINT1/MINT(400),VINT(400)
34250 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34251 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34252 COMMON/PYINT4/MWID(500),WIDS(500,5)
34253 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
34254 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34255 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34256 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34257 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34258 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34259 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
34260 C...Local arrays and complex variables
34261 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34262 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
34263 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
34264 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
34265 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
34266 COMPLEX*16 DVVS,DVVT,DVVU
34269 C...Combinations of weak mixing angle.
34271 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34273 C...Convert almost equivalent technicolor processes into
34274 C...a few basic processes, and set distinguishing parameters.
34275 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
34278 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
34279 CS2W=1D0-2D0*PARU(102)
34280 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
34282 CSXI=COS(ASIN(RTCM(3)))
34283 CSXIP=COS(ASIN(RTCM(4)))
34284 QUPD=2D0*RTCM(2)-1D0
34285 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
34286 C... rho_tc0 -> W_L W_L
34287 IF(ISUB.EQ.361) THEN
34291 C... rho_tc0 -> W_L pi_tc-
34292 ELSEIF(ISUB.EQ.362) THEN
34296 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34298 ELSEIF(ISUB.EQ.363) THEN
34302 CAB2=(1D0-RTCM(3)**2)**2
34303 C... rho_tc0/omega_tc -> gamma pi_tc
34304 ELSEIF(ISUB.EQ.364) THEN
34313 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
34315 ELSEIF(ISUB.EQ.365) THEN
34319 VRGP=CSXIP/RTCM(12)
34324 VAGP=2D0*Q2UD*CSXIP
34325 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
34327 ELSEIF(ISUB.EQ.366) THEN
34331 VOGP=CSXI*CT2W/RTCM(12)
34332 VRGP=-QUPD*CSXI*TANW/RTCM(12)
34335 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
34336 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
34338 ELSEIF(ISUB.EQ.367) THEN
34342 VRGP=CSXIP*CT2W/RTCM(12)
34343 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
34346 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
34347 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
34349 ELSEIF(ISUB.EQ.368) THEN
34353 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
34357 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
34358 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
34359 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
34360 C... rho_tc+ -> W_L Z_L
34361 ELSEIF(ISUB.EQ.370) THEN
34366 ELSEIF(ISUB.EQ.371) THEN
34370 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34372 ELSEIF(ISUB.EQ.372) THEN
34376 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34378 ELSEIF(ISUB.EQ.373) THEN
34382 CAB2=(1D0-RTCM(3)**2)**2
34384 ELSEIF(ISUB.EQ.374) THEN
34389 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
34391 ELSEIF(ISUB.EQ.375) THEN
34395 VRGP=-QUPD*CSXI*TANW
34396 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
34397 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
34399 ELSEIF(ISUB.EQ.376) THEN
34404 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
34407 ELSEIF(ISUB.EQ.377) THEN
34412 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
34413 VWGP=CSXIP/(2D0*PARU(102))
34417 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
34418 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
34419 IF(ITCM(5).LE.4) THEN
34437 ELSEIF(ITCM(5).EQ.5) THEN
34439 IF(ITCM(2).EQ.0) THEN
34444 ALPRHT=2.91D0*(3D0/ITCM(1))
34445 SIN2T=2D0*TANT3/(TANT3**2+1D0)
34446 SINT3=TANT3/SQRT(TANT3**2+1D0)
34447 XIG=SQRT(PYALPS(SH)/ALPRHT)
34448 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
34449 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
34450 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
34451 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
34452 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
34453 & SINT3**2)*2D0/SIN2T
34454 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
34455 & SINT3**2)*2D0/SIN2T
34457 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
34458 SM1112=X12*RTCM(28)**2*SIN2T
34459 SM1121=-X21*RTCM(28)**2*SIN2T
34462 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
34463 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
34466 ZTC(1,1)=DCMPLX(SH,0D0)
34467 CALL PYWIDT(3100021,SH,WDTP,WDTE)
34468 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
34469 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
34470 CALL PYWIDT(3100113,SH,WDTP,WDTE)
34471 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
34472 CALL PYWIDT(3400113,SH,WDTP,WDTE)
34473 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
34474 CALL PYWIDT(3200113,SH,WDTP,WDTE)
34475 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
34476 CALL PYWIDT(3300113,SH,WDTP,WDTE)
34477 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
34479 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
34483 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
34484 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
34485 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
34486 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
34499 CALL PYLDCM(ZTC,6,6,INDX,D)
34503 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34508 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34514 XIG=SQRT(PYALPS(-TH)/ALPRHT)
34516 ZTC(1,1)=DCMPLX(TH)
34517 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
34518 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
34519 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
34520 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
34521 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
34523 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
34527 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
34528 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
34529 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
34530 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
34542 CALL PYLDCM(ZTC,6,6,INDX,D)
34546 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34550 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34556 XIG=SQRT(PYALPS(-UH)/ALPRHT)
34558 ZTC(1,1)=DCMPLX(UH,0D0)
34559 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
34560 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
34561 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
34562 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
34563 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
34565 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
34569 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
34570 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
34571 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
34572 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
34584 CALL PYLDCM(ZTC,6,6,INDX,D)
34588 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34592 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34599 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
34600 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
34601 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
34602 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
34603 DQGS=DGGS-DGVS*DCMPLX(TANT3)
34604 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34606 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
34607 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
34608 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
34609 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
34610 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34611 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34614 SQDQTS=ABS(DQTS)**2
34615 SQDQQS=ABS(DQQS)**2
34616 SQDQQT=ABS(DQQT)**2
34617 SQDQQU=ABS(DQQU)**2
34618 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
34620 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
34622 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
34624 SQDGGS=ABS(DGGS)**2
34625 SQDGGT=ABS(DGGT)**2
34626 SQDGGU=ABS(DGGU)**2
34630 REDGTU=DBLE(DGGU*DCONJG(DGGT))
34631 REDGSU=DBLE(DGGU*DCONJG(DGGS))
34632 REDGST=DBLE(DGGS*DCONJG(DGGT))
34633 REDQST=DBLE(DQQS*DCONJG(DQQT))
34634 REDQTU=DBLE(DQQT*DCONJG(DQQU))
34639 C...Differential cross section expressions.
34641 IF(ISUB.LE.190) THEN
34642 IF(ISUB.EQ.149) THEN
34643 C...g + g -> eta_tc
34644 KCTC=PYCOMP(KTECHN+331)
34645 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
34647 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
34648 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34650 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
34652 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34657 SIGH(NCHN)=HI*FACBW*HF
34660 ELSEIF(ISUB.EQ.165) THEN
34661 C...q + qbar -> l+ + l- (including contact term for compositeness)
34662 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34663 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34664 KFF=IABS(KFPR(ISUB,1))
34666 AF=SIGN(1D0,EF+0.1D0)
34671 IF(KFF.LE.10) FCOF=3D0
34673 IF(KFF.EQ.6) WID2=WIDS(6,1)
34674 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
34675 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
34676 DO 260 I=MMINA,MMAXA
34677 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
34678 EI=KCHG(IABS(I),1)/3D0
34679 AI=SIGN(1D0,EI+0.1D0)
34684 IF(IABS(I).LE.10) FCOI=FACA/3D0
34685 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
34686 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
34687 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
34688 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
34690 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
34691 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
34693 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
34694 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
34695 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
34696 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
34697 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
34702 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
34705 ELSEIF(ISUB.EQ.166) THEN
34706 C...q + q'bar -> l + nu_l (including contact term for compositeness)
34707 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
34708 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
34709 KFF=IABS(KFPR(ISUB,1))
34711 IF(KFF.LE.10) FCOF=3D0
34712 DO 280 I=MMIN1,MMAX1
34713 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
34715 DO 270 J=MMIN2,MMAX2
34716 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
34718 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
34719 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34722 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
34724 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
34725 & MOD(J,2).EQ.0)) THEN
34726 IF(KFF.EQ.5) WID2=WIDS(6,2)
34727 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
34728 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
34730 IF(KFF.EQ.5) WID2=WIDS(6,3)
34731 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
34732 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
34738 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
34739 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
34740 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
34745 ELSEIF(ISUB.LE.200) THEN
34746 IF(ISUB.EQ.191) THEN
34747 C...q + qbar -> rho_tc0.
34748 KCTC=PYCOMP(KTECHN+113)
34749 SQMRHT=PMAS(KCTC,1)**2
34750 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34752 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
34753 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34754 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34755 ALPRHT=2.91D0*(3D0/ITCM(1))
34756 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
34757 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
34758 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34759 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34760 DO 290 I=MMINA,MMAXA
34761 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
34763 EI=KCHG(IABS(I),1)/3D0
34764 AI=SIGN(1D0,EI+0.1D0)
34768 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
34769 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
34770 IF(IA.LE.10) HI=HI*FACA/3D0
34775 SIGH(NCHN)=HI*FACBW*HF
34778 ELSEIF(ISUB.EQ.192) THEN
34779 C...q + qbar' -> rho_tc+/-.
34780 KCTC=PYCOMP(KTECHN+213)
34781 SQMRHT=PMAS(KCTC,1)**2
34782 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
34784 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
34785 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34786 ALPRHT=2.91D0*(3D0/ITCM(1))
34787 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
34788 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
34789 DO 310 I=MMIN1,MMAX1
34790 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
34792 DO 300 J=MMIN2,MMAX2
34793 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
34795 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
34796 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34798 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34799 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
34801 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
34806 SIGH(NCHN)=HI*FACBW*HF
34810 ELSEIF(ISUB.EQ.193) THEN
34811 C...q + qbar -> omega_tc0.
34812 KCTC=PYCOMP(KTECHN+223)
34813 SQMOMT=PMAS(KCTC,1)**2
34814 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34816 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
34817 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34818 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34819 ALPRHT=2.91D0*(3D0/ITCM(1))
34820 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
34821 & (2D0*RTCM(2)-1D0)**2
34822 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34823 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34824 DO 320 I=MMINA,MMAXA
34825 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
34827 EI=KCHG(IABS(I),1)/3D0
34828 AI=SIGN(1D0,EI+0.1D0)
34832 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
34833 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
34834 IF(IA.LE.10) HI=HI*FACA/3D0
34839 SIGH(NCHN)=HI*FACBW*HF
34842 ELSEIF(ISUB.EQ.194) THEN
34843 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
34845 ALPRHT=2.91D0*(3D0/ITCM(1))
34847 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
34848 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
34850 QUPD=2D0*RTCM(2)-1D0
34851 FAR=SQRT(AEM/ALPRHT)
34859 CALL PYWIDT(23,SH,WDTP,WDTE)
34860 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
34861 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34862 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
34863 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34864 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
34865 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
34866 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
34867 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
34868 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
34869 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
34871 XWRHT=1D0/(4D0*XW*(1D0-XW))
34872 KFF=IABS(KFPR(ISUB,1))
34874 AF=SIGN(1D0,EF+0.1D0)
34879 IF(KFF.LE.10) FCOF=3D0
34882 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
34883 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
34884 DZZ=DZZ*DCMPLX(XWRHT,0D0)
34885 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
34887 DO 330 I=MMINA,MMAXA
34888 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
34889 EI=KCHG(IABS(I),1)/3D0
34890 AI=SIGN(1D0,EI+0.1D0)
34895 IF(IABS(I).LE.10) FCOI=FCOI/3D0
34896 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
34897 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
34898 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
34899 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
34900 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
34901 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
34906 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
34909 ELSEIF(ISUB.EQ.195) THEN
34910 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
34913 ALPRHT=2.91D0*(3D0/ITCM(1))
34914 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
34916 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
34917 CALL PYWIDT(24,SH,WDTP,WDTE)
34918 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
34919 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
34920 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
34923 IF(KFA.LE.8) FCOF=3D0
34924 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
34925 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
34927 DO 350 I=MMIN1,MMAX1
34928 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
34930 DO 340 J=MMIN2,MMAX2
34931 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
34933 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
34934 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34936 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34938 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
34943 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
34948 ELSEIF(ISUB.LE.380) THEN
34949 IF(ISUB.EQ.361) THEN
34950 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
34951 FACA=(SH**2*BE34**2-(TH-UH)**2)
34952 ALPRHT=2.91D0*(3D0/ITCM(1))
34953 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
34954 FAR=SQRT(AEM/ALPRHT)
34962 CALL PYWIDT(23,SH,WDTP,WDTE)
34963 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
34964 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34965 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
34966 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34967 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
34968 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
34969 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
34970 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
34971 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
34972 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
34973 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
34974 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
34976 DO 360 I=MMINA,MMAXA
34977 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
34979 EI=KCHG(IABS(I),1)/3D0
34980 AI=SIGN(1D0,EI+0.1D0)
34982 VALI=0.25D0*(VI+AI)
34983 VARI=0.25D0*(VI-AI)
34984 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
34985 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
34986 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
34987 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
34988 HI=ABS(F2L)**2+ABS(F2R)**2
34989 IF(IA.LE.10) HI=HI/3D0
34994 IF(KFA.EQ.KFB) THEN
34995 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
34997 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35002 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35006 ELSEIF(ISUB.EQ.364) THEN
35007 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35009 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35010 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35011 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35013 ALPRHT=2.91D0*(3D0/ITCM(1))
35014 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35015 FAR=SQRT(AEM/ALPRHT)
35023 CALL PYWIDT(23,SH,WDTP,WDTE)
35024 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35025 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35026 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35027 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35028 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35029 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35030 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35031 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
35032 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
35033 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
35034 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
35035 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
35036 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
35037 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
35039 DO 370 I=MMINA,MMAXA
35040 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35042 EI=KCHG(IABS(I),1)/3D0
35043 AI=SIGN(1D0,EI+0.1D0)
35045 VALI=0.25D0*(VI+AI)
35046 VARI=0.25D0*(VI-AI)
35047 C...........Add in anomaly contribution
35048 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35049 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35050 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35051 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35052 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35053 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35054 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35055 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35056 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35057 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35058 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35059 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35060 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35061 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35063 IF(IA.LE.10) HI=HI/3D0
35068 IF(ISUBSV.NE.368) THEN
35069 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
35071 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35076 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35080 ELSEIF(ISUB.EQ.370) THEN
35081 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
35083 FACA=(SH**2*BE34**2-(TH-UH)**2)
35084 ALPRHT=2.91D0*(3D0/ITCM(1))
35085 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
35086 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35087 CALL PYWIDT(24,SH,WDTP,WDTE)
35088 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35089 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35090 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35091 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
35094 HP=HP*ABS(DWW+DWRHO)**2
35095 DO 390 I=MMIN1,MMAX1
35096 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
35098 DO 380 J=MMIN2,MMAX2
35099 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
35101 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
35102 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35104 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35106 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35111 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
35112 & WIDS(PYCOMP(KFB),2)
35116 ELSEIF(ISUB.EQ.374) THEN
35117 C...f + fbar' -> gamma pi_tc
35118 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
35119 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35120 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
35121 ALPRHT=2.91D0*(3D0/ITCM(1))
35122 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
35123 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35124 CALL PYWIDT(24,SH,WDTP,WDTE)
35125 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35126 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35127 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35128 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
35130 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
35131 HP=HP*(AFAC*ABS(DWRHO)**2+
35132 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
35133 DO 410 I=MMIN1,MMAX1
35134 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
35136 DO 400 J=MMIN2,MMAX2
35137 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
35139 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
35140 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35142 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35144 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35149 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
35150 & WIDS(PYCOMP(KFB),2)
35155 ELSEIF(ISUB.LE.390) THEN
35156 IF(ISUB.EQ.381) THEN
35157 C...f + f' -> f + f' (g exchange)
35158 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
35159 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
35160 & MSTP(34)*2D0/3D0*UH2*REDQST)
35161 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
35162 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
35163 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
35164 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
35165 C...Modifications from contact interactions (compositeness)
35166 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
35167 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
35168 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
35169 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
35170 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
35171 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
35172 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
35173 ELSEIF(ITCM(5).EQ.5) THEN
35178 CSM.......Check this change from
35182 DO 430 I=MMIN1,MMAX1
35184 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35185 DO 420 J=MMIN2,MMAX2
35187 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35192 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
35195 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
35198 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
35199 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
35206 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
35207 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
35208 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
35210 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
35211 SIGH(NCHN)=0.5D0*FACCI2*RATCII
35217 ELSEIF(ISUB.EQ.382) THEN
35218 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
35219 CALL PYWIDT(21,SH,WDTP,WDTE)
35220 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
35221 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35222 IF(ITCM(5).EQ.1) THEN
35223 C...Modifications from contact interactions (compositeness)
35226 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
35227 & WDTE(I,2)+WDTE(I,4))
35229 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
35230 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
35231 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35232 ELSEIF(ITCM(5).EQ.5) THEN
35233 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
35234 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
35235 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
35237 DO 450 I=MMINA,MMAXA
35238 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35239 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
35244 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
35246 ELSEIF(ITCM(5).EQ.5) THEN
35258 ELSEIF(ISUB.EQ.383) THEN
35259 C...f + fbar -> g + g (q + qbar -> g + g only)
35260 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35261 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
35262 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35263 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
35264 IF(ITCM(5).EQ.5) THEN
35265 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35266 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
35267 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35268 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
35270 DO 460 I=MMINA,MMAXA
35271 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35272 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35277 SIGH(NCHN)=0.5D0*FACGG1
35278 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
35283 SIGH(NCHN)=0.5D0*FACGG2
35284 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
35287 ELSEIF(ISUB.EQ.384) THEN
35288 C...f + g -> f + g (q + g -> q + g only)
35289 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
35290 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
35291 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
35292 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
35293 DO 480 I=MMINA,MMAXA
35294 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
35296 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
35297 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
35300 ISIG(NCHN,3-ISDE)=21
35305 ISIG(NCHN,3-ISDE)=21
35311 ELSEIF(ISUB.EQ.385) THEN
35312 C...g + g -> f + fbar (g + g -> q + qbar only)
35313 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
35315 C...Begin by d, u, s flavours.
35317 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
35318 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
35319 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
35320 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
35321 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
35322 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
35323 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35324 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
35325 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35326 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
35337 C...Next c and b flavours: modified that and uhat for fixed
35338 C...cos(theta-hat).
35340 SQMAVG=PMAS(IFL,1)**2
35341 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
35342 BE34=SQRT(1D0-4D0*SQMAVG/SH)
35343 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35344 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35345 THUHQ=THQ*UHQ-SQMAVG*SH
35346 IF(MSTP(34).EQ.0) THEN
35347 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
35348 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
35350 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35351 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
35352 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35353 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
35355 IF(ITCM(5).GE.5) THEN
35357 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
35358 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35359 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
35360 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35362 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
35363 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35364 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
35365 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35368 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
35369 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
35373 ISIG(NCHN,3)=1+2*(IFL-3)
35378 ISIG(NCHN,3)=2+2*(IFL-3)
35384 ELSEIF(ISUB.EQ.386) THEN
35386 IF(ITCM(5).LE.4) THEN
35387 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
35388 & 2D0*TH/SH+TH2/SH2)*FACA
35389 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
35390 & 2D0*SH/UH+SH2/UH2)*FACA
35391 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
35392 & 2D0*UH/TH+UH2/TH2)
35394 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
35395 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
35396 & 4D0*REDGST*(SH + 2D0*TH)*
35397 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
35398 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
35399 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
35400 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
35401 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
35402 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
35403 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
35404 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
35405 & 4D0*REDGSU*(SH + 2D0*UH)*
35406 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
35407 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
35408 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
35409 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
35410 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
35411 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
35412 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
35413 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
35414 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
35415 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
35416 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
35417 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
35418 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
35419 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
35420 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
35421 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
35422 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
35423 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
35424 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
35425 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
35426 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
35427 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
35429 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
35434 SIGH(NCHN)=0.5D0*FACGG1
35439 SIGH(NCHN)=0.5D0*FACGG2
35444 SIGH(NCHN)=0.5D0*FACGG3
35447 ELSEIF(ISUB.EQ.387) THEN
35448 C...q + qbar -> Q + Qbar
35449 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
35450 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35451 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35452 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
35454 IF(ITCM(5).GE.5) THEN
35455 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
35456 FACQQB=FACQQB*SH2*SQDQTS
35458 FACQQB=FACQQB*SH2*SQDQQS
35461 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
35463 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
35464 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
35466 DO 520 I=MMINA,MMAXA
35467 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35468 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
35476 ELSEIF(ISUB.EQ.388) THEN
35477 C...g + g -> Q + Qbar
35478 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
35479 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35480 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35481 THUHQ=THQ*UHQ-SQMAVG*SH
35482 IF(MSTP(34).EQ.0) THEN
35483 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
35484 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
35486 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35487 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
35488 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35489 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
35491 IF(ITCM(5).GE.5) THEN
35492 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
35493 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
35494 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35495 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
35496 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35498 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
35499 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35500 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
35501 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35504 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
35505 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
35506 IF(MSTP(35).GE.1) THEN
35507 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
35508 FACQQ1=FACQQ1*FATRE
35509 FACQQ2=FACQQ2*FATRE
35512 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
35513 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
35516 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
35536 C*********************************************************************
35539 C...Subprocess cross sections for assorted exotic processes,
35540 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
35541 C...Auxiliary to PYSIGH.
35543 SUBROUTINE PYSGEX(NCHN,SIGS)
35545 C...Double precision and integer declarations
35546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35547 IMPLICIT INTEGER(I-N)
35548 INTEGER PYK,PYCHGE,PYCOMP
35549 C...Parameter statement to help give large particle numbers.
35550 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35551 &KEXCIT=4000000,KDIMEN=5000000)
35553 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35554 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35555 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35556 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35557 COMMON/PYINT1/MINT(400),VINT(400)
35558 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35559 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35560 COMMON/PYINT4/MWID(500),WIDS(500,5)
35561 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35562 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35563 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35564 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35565 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35566 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35567 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35569 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35571 C...Differential cross section expressions.
35573 IF(ISUB.LE.160) THEN
35574 IF(ISUB.EQ.141) THEN
35575 C...f + fbar -> gamma*/Z0/Z'0
35576 SQMZP=PMAS(32,1)**2
35578 CALL PYWIDT(32,SH,WDTP,WDTE)
35584 FACZP=4D0*COMFAC*3D0
35585 DO 100 I=MMINA,MMAXA
35586 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
35587 EI=KCHG(IABS(I),1)/3D0
35593 VPI=PARU(123-2*MOD(IABS(I),2))
35594 API=PARU(124-2*MOD(IABS(I),2))
35595 ELSEIF(IA.LE.4) THEN
35596 VPI=PARJ(182-2*MOD(IABS(I),2))
35597 API=PARJ(183-2*MOD(IABS(I),2))
35599 VPI=PARJ(190-2*MOD(IABS(I),2))
35600 API=PARJ(191-2*MOD(IABS(I),2))
35604 VPI=PARU(127-2*MOD(IABS(I),2))
35605 API=PARU(128-2*MOD(IABS(I),2))
35606 ELSEIF(IA.LE.14) THEN
35607 VPI=PARJ(186-2*MOD(IABS(I),2))
35608 API=PARJ(187-2*MOD(IABS(I),2))
35610 VPI=PARJ(194-2*MOD(IABS(I),2))
35611 API=PARJ(195-2*MOD(IABS(I),2))
35615 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
35617 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
35619 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
35624 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
35625 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
35626 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
35627 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
35628 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
35629 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
35630 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
35631 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
35634 ELSEIF(ISUB.EQ.142) THEN
35635 C...f + fbar' -> W'+/-
35636 SQMWP=PMAS(34,1)**2
35637 CALL PYWIDT(34,SH,WDTP,WDTE)
35639 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
35640 HP=AEM/(24D0*XW)*SH
35641 DO 120 I=MMIN1,MMAX1
35642 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
35644 DO 110 J=MMIN2,MMAX2
35645 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
35647 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
35648 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35650 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35651 HI=HP*(PARU(133)**2+PARU(134)**2)
35652 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
35653 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35658 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
35659 SIGH(NCHN)=HI*FACBW*HF
35663 ELSEIF(ISUB.EQ.144) THEN
35666 CALL PYWIDT(41,SH,WDTP,WDTE)
35668 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
35669 HP=AEM/(12D0*XW)*SH
35670 DO 140 I=MMIN1,MMAX1
35671 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
35673 DO 130 J=MMIN2,MMAX2
35674 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
35676 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
35678 IF(IA.LE.10) HI=HI*FACA/3D0
35679 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
35684 SIGH(NCHN)=HI*FACBW*HF
35688 ELSEIF(ISUB.EQ.145) THEN
35689 C...q + l -> LQ (leptoquark)
35690 SQMLQ=PMAS(42,1)**2
35691 CALL PYWIDT(42,SH,WDTP,WDTE)
35693 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
35694 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
35696 KFLQQ=KFDP(MDCY(42,2),1)
35697 KFLQL=KFDP(MDCY(42,2),2)
35698 DO 160 I=MMIN1,MMAX1
35699 IF(KFAC(1,I).EQ.0) GOTO 160
35701 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
35702 DO 150 J=MMIN2,MMAX2
35703 IF(KFAC(2,J).EQ.0) GOTO 150
35705 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
35706 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
35707 IF(JA.EQ.IA) GOTO 150
35708 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
35709 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
35711 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
35716 SIGH(NCHN)=HI*FACBW*HF
35720 ELSEIF(ISUB.EQ.146) THEN
35721 C...e + gamma* -> e* (excited lepton)
35722 KFQSTR=KFPR(ISUB,1)
35723 KCQSTR=PYCOMP(KFQSTR)
35724 KFQEXC=MOD(KFQSTR,KEXCIT)
35725 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
35727 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
35728 QF=-RTCM(43)/2D0-RTCM(44)/2D0
35729 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
35730 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
35733 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
35735 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
35736 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
35738 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35739 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
35742 ISIG(NCHN,3-ISDE)=22
35744 SIGH(NCHN)=HI*FACBW*HF
35748 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
35749 C...d + g -> d* and u + g -> u* (excited quarks)
35750 KFQSTR=KFPR(ISUB,1)
35751 KCQSTR=PYCOMP(KFQSTR)
35752 KFQEXC=MOD(KFQSTR,KEXCIT)
35753 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
35755 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
35756 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
35757 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
35760 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
35762 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
35763 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
35765 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35766 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
35769 ISIG(NCHN,3-ISDE)=21
35771 SIGH(NCHN)=HI*FACBW*HF
35776 ELSEIF(ISUB.LE.190) THEN
35777 IF(ISUB.EQ.162) THEN
35778 C...q + g -> LQ + lbar; LQ=leptoquark
35779 SQMLQ=PMAS(42,1)**2
35780 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
35781 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
35782 KFLQQ=KFDP(MDCY(42,2),1)
35783 DO 220 I=MMINA,MMAXA
35784 IF(IABS(I).NE.KFLQQ) GOTO 220
35787 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
35788 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
35791 ISIG(NCHN,3-ISDE)=21
35793 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
35797 ELSEIF(ISUB.EQ.163) THEN
35798 C...g + g -> LQ + LQbar; LQ=leptoquark
35799 SQMLQ=PMAS(42,1)**2
35800 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
35801 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
35802 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
35803 & ((TH-SQMLQ)*(UH-SQMLQ)))
35804 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
35808 C...Since don't know proper colour flow, randomize between alternatives
35809 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
35813 ELSEIF(ISUB.EQ.164) THEN
35814 C...q + qbar -> LQ + LQbar; LQ=leptoquark
35815 DELTA=0.25D0*(SQM3-SQM4)**2/SH
35816 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
35819 C SQMLQ=PMAS(42,1)**2
35820 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
35821 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
35822 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
35823 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
35824 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
35825 KFLQQ=KFDP(MDCY(42,2),1)
35826 DO 240 I=MMINA,MMAXA
35827 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35828 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
35834 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
35837 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
35838 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
35839 KFQSTR=KFPR(ISUB,2)
35840 KCQSTR=PYCOMP(KFQSTR)
35841 KFQEXC=MOD(KFQSTR,KEXCIT)
35842 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
35843 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
35844 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
35845 C...Propagators: as simulated in PYOFSH and as desired
35846 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
35847 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
35848 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
35849 GMMQC=SQRT(SQM4)*WDTP(0)
35850 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
35851 FACQSA=FACQSA*HBW4C/HBW4
35852 FACQSB=FACQSB*HBW4C/HBW4
35853 C...Branching ratios.
35854 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
35855 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
35856 DO 260 I=MMIN1,MMAX1
35858 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
35859 DO 250 J=MMIN2,MMAX2
35861 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
35862 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
35867 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
35868 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
35873 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
35874 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
35875 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
35880 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
35881 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
35882 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
35883 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
35888 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
35889 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
35894 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
35895 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
35896 ELSEIF(I.EQ.-J) THEN
35901 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35902 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35907 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35908 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35909 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
35914 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
35915 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
35916 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
35921 ELSEIF(ISUB.EQ.169) THEN
35922 C...q + qbar -> e + e* (excited lepton)
35923 KFQSTR=KFPR(ISUB,2)
35924 KCQSTR=PYCOMP(KFQSTR)
35925 KFQEXC=MOD(KFQSTR,KEXCIT)
35926 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
35927 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
35928 C...Propagators: as simulated in PYOFSH and as desired
35929 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
35930 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
35931 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
35932 GMMQC=SQRT(SQM4)*WDTP(0)
35933 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
35934 FACQSB=FACQSB*HBW4C/HBW4
35935 C...Branching ratios.
35936 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
35937 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
35938 DO 270 I=MMIN1,MMAX1
35940 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
35943 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
35948 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35949 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35954 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35955 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35959 ELSEIF(ISUB.LE.360) THEN
35960 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
35961 C...l + l -> H_L++/-- or H_R++/--.
35963 KFREC=PYCOMP(KFRES)
35964 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
35966 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
35967 DO 290 I=MMIN1,MMAX1
35969 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
35971 DO 280 J=MMIN2,MMAX2
35973 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
35975 IF(I*J.LT.0) GOTO 280
35976 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35981 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
35982 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
35983 SIGH(NCHN)=HI*FACBW*HF
35987 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
35988 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
35990 KFREC=PYCOMP(KFRES)
35991 C...Propagators: as simulated in PYOFSH and as desired
35992 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
35993 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
35994 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
35995 GMMC=SQRT(SQM3)*WDTP(0)
35996 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
35997 FHCC=COMFAC*AEM*HBW3C/HBW3
35998 DO 310 I=MMINA,MMAXA
36000 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36002 J=ISIGN(KFPR(ISUB,2),-I)
36003 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36004 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36005 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36007 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36008 & (TH-SQM4)*SH)/(TH-SQM4)**2
36009 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36011 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36012 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36013 & ((UH-SQM3)*(TH-SQM4))
36014 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36015 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36016 & ((UH-SQM3)*(SH-SQML))
36017 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36018 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36019 & ((SH-SQML)*(TH-SQM4))
36020 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36021 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36023 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36024 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36027 ISIG(NCHN,3-ISDE)=22
36029 SIGH(NCHN)=FHCC*SMM*WIDSC
36033 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36034 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36036 KFREC=PYCOMP(KFRES)
36037 SQMH=PMAS(KFREC,1)**2
36038 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36039 C...Propagators: H++/-- as simulated in PYOFSH and as desired
36040 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36041 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36042 GMMH3=SQRT(SQM3)*WDTP(0)
36043 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36044 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36045 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36046 GMMH4=SQRT(SQM4)*WDTP(0)
36047 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36048 C...Kinematical and coupling functions
36049 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36050 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36051 C...Loop over allowed flavours
36052 DO 320 I=MMINA,MMAXA
36053 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36054 EI=KCHG(IABS(I),1)/3D0
36055 AI=SIGN(1D0,EI+0.1D0)
36058 IF(IABS(I).LE.10) FCOI=FACA/3D0
36059 IF(ISUB.EQ.349) THEN
36060 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36061 IF(IABS(I).LT.10) THEN
36062 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36063 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36064 & (VI**2+AI**2)*XWHH**2*HBWZ)
36066 IAOFF=181+3*((IABS(I)-11)/2)
36067 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36069 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36070 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36071 & (VI**2+AI**2)*XWHH**2*HBWZ)+
36072 & 8D0*AEM*(EI*HSUM/(SH*TH)+
36073 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
36077 IF(IABS(I).LT.10) THEN
36078 DSIGHH=8D0*AEM**2*EI**2/SH2
36080 IAOFF=181+3*((IABS(I)-11)/2)
36081 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36083 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
36091 SIGH(NCHN)=FACHH*FCOI*DSIGHH
36094 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
36095 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
36097 KFREC=PYCOMP(KFRES)
36098 SQMH=PMAS(KFREC,1)**2
36099 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
36100 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
36101 & PMAS(PYCOMP(9900024),1)**2
36102 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
36103 FACPRT=1D0/((VINT(204)**2-VINT(215))*
36104 & (VINT(209)**2-VINT(216)))
36105 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
36106 & (VINT(209)**2+2D0*VINT(218)))
36107 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36109 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
36110 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
36112 DO 340 I=MMIN1,MMAX1
36113 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
36114 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
36115 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
36116 DO 330 J=MMIN2,MMAX2
36117 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
36118 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
36119 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
36121 IF(IABS(KCHH).NE.2) GOTO 330
36122 FACLR=VINT(180+I)*VINT(180+J)
36123 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36124 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
36125 FACPRP=0.5D0*(FACPRT+FACPRU)**2
36133 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
36137 ELSEIF(ISUB.EQ.353) THEN
36138 C...f + fbar -> Z_R0
36139 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
36140 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
36142 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
36143 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36144 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
36145 DO 350 I=MMINA,MMAXA
36146 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
36147 IF(IABS(I).LE.8) THEN
36148 EI=KCHG(IABS(I),1)/3D0
36149 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
36150 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
36155 HI=HP*(VI**2+AI**2)
36156 IF(IABS(I).LE.10) HI=HI*FACA/3D0
36161 SIGH(NCHN)=HI*FACBW*HF
36164 ELSEIF(ISUB.EQ.354) THEN
36165 C...f + fbar' -> W_R+/-
36166 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
36167 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
36169 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
36170 HP=AEM/(24D0*XW)*SH
36171 DO 370 I=MMIN1,MMAX1
36172 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
36174 DO 360 J=MMIN2,MMAX2
36175 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
36177 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
36178 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36180 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36182 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36187 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36188 SIGH(NCHN)=HI*FACBW*HF
36193 ELSEIF(ISUB.LE.400) THEN
36194 IF(ISUB.EQ.391) THEN
36195 C...f + fbar -> G*.
36196 KFGSTR=KFPR(ISUB,1)
36197 KCGSTR=PYCOMP(KFGSTR)
36198 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
36200 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36201 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
36202 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
36203 C...Modify cross section in wings of peak.
36204 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
36205 DO 380 I=MMINA,MMAXA
36206 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
36208 IF(IABS(I).LE.10) HI=HI*FACA/3D0
36216 ELSEIF(ISUB.EQ.392) THEN
36218 KFGSTR=KFPR(ISUB,1)
36219 KCGSTR=PYCOMP(KFGSTR)
36220 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
36222 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36223 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
36224 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
36225 C...Modify cross section in wings of peak.
36226 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
36227 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
36235 ELSEIF(ISUB.EQ.393) THEN
36236 C...q + qbar -> g + G*.
36237 KFGSTR=KFPR(ISUB,2)
36238 KCGSTR=PYCOMP(KFGSTR)
36239 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
36240 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
36241 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
36243 C...Propagators: as simulated in PYOFSH and as desired
36244 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36245 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36246 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36247 HS=SQRT(SQM4)*WDTP(0)
36248 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36249 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36250 FACG=FACG*HBW4C/HBW4
36251 DO 400 I=MMINA,MMAXA
36252 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36253 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36261 ELSEIF(ISUB.EQ.394) THEN
36262 C...q + g -> q + G*.
36263 KFGSTR=KFPR(ISUB,2)
36264 KCGSTR=PYCOMP(KFGSTR)
36265 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
36266 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
36267 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
36268 & 2D0*TH2*TH/(UH*SH2))
36269 C...Propagators: as simulated in PYOFSH and as desired
36270 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36271 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36272 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36273 HS=SQRT(SQM4)*WDTP(0)
36274 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36275 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36276 FACG=FACG*HBW4C/HBW4
36277 DO 420 I=MMINA,MMAXA
36278 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
36280 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
36281 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
36284 ISIG(NCHN,3-ISDE)=21
36290 ELSEIF(ISUB.EQ.395) THEN
36291 C...g + g -> g + G*.
36292 KFGSTR=KFPR(ISUB,2)
36293 KCGSTR=PYCOMP(KFGSTR)
36294 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
36295 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
36296 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
36297 C...Propagators: as simulated in PYOFSH and as desired
36298 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36299 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36300 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36301 HS=SQRT(SQM4)*WDTP(0)
36302 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36303 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36304 FACG=FACG*HBW4C/HBW4
36305 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
36318 C*********************************************************************
36321 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
36322 C...parton distributions according to a few different parametrizations.
36323 C...Note that what is coded is x times the probability distribution,
36324 C...i.e. xq(x,Q2) etc.
36326 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
36328 C...Double precision and integer declarations.
36329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36330 IMPLICIT INTEGER(I-N)
36331 INTEGER PYK,PYCHGE,PYCOMP
36333 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
36334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36336 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36337 COMMON/PYINT1/MINT(400),VINT(400)
36338 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
36340 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
36341 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
36342 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
36343 & XMI(2,240),PT2MI(240),IMISEP(0:240)
36344 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
36347 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
36348 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
36351 C...Interface to PDFLIB.
36352 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
36354 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
36355 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
36356 CHARACTER*20 PARM(20)
36357 DATA VALUE/20*0D0/,PARM/20*' '/
36359 C...Data related to Schuler-Sjostrand photon distributions.
36360 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
36362 C...Valence PDF momentum integral parametrizations PER PARTON!
36363 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
36364 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
36365 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
36366 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
36368 C...Reset parton distributions.
36377 C...Check x and particle species.
36378 IF(X.LE.0D0.OR.X.GE.1D0) THEN
36379 WRITE(MSTU(11),5000) X
36383 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
36384 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
36385 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
36386 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
36387 &KFA.NE.310.AND.KFA.NE.130) THEN
36388 WRITE(MSTU(11),5100) KF
36392 C...Electron (or muon or tau) parton distribution call.
36393 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
36394 CALL PYPDEL(KFA,X,Q2,XPEL)
36399 C...Photon parton distribution call (VDM+anomalous).
36400 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
36401 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
36402 CALL PYPDGA(X,Q2,XPGA)
36406 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
36409 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
36410 XPVAL(4)=MIN(XPQ(4),XPVU)
36411 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
36417 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
36420 IF(MSTP(55).GE.7) P2MX=4.0D0
36421 IF(MSTP(57).EQ.0) Q2MX=P2MX
36423 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36424 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36427 XPVAL(KFL)=VXPDGM(KFL)
36430 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
36433 IF(MSTP(55).GE.11) P2MX=4.0D0
36434 IF(MSTP(57).EQ.0) Q2MX=P2MX
36436 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36437 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36439 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
36440 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
36443 ELSEIF(MSTP(56).EQ.2) THEN
36444 C...Call PDFLIB parton distributions.
36448 VALUE(2)=MSTP(55)/1000
36450 VALUE(3)=MOD(MSTP(55),1000)
36451 IF(MINT(93).NE.3000000+MSTP(55)) THEN
36452 CALL PDFSET(PARM,VALUE)
36453 MINT(93)=3000000+MSTP(55)
36456 QQ2=MAX(0D0,Q2MIN,Q2)
36457 IF(MSTP(57).EQ.0) QQ2=Q2MIN
36459 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36461 IF(MSTP(55).EQ.5004) THEN
36462 IF(5D0*P2.LT.QQ2.AND.
36463 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
36464 & P2.GE.0D0.AND.P2.LT.10D0.AND.
36465 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
36466 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
36481 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
36509 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
36512 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
36513 XPVAL(4)=MIN(XPQ(4),XPVU)
36514 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
36521 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
36524 C...Pion/gammaVDM parton distribution call.
36525 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
36526 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
36527 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
36528 & MSTP(55).LE.12) THEN
36529 ISET=1+MOD(MSTP(55)-1,4)
36532 IF(ISET.GE.3) P2MX=4.0D0
36533 IF(MSTP(57).EQ.0) Q2MX=P2MX
36535 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36536 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36538 XPQ(KFL)=XPVMD(KFL)
36539 XPVAL(KFL)=VXPVMD(KFL)
36542 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
36543 CALL PYPDPI(X,Q2,XPPI)
36547 XPVAL(2)=XPQ(2)-XPQ(-2)
36548 XPVAL(-1)=XPQ(-1)-XPQ(1)
36549 ELSEIF(MSTP(54).EQ.2) THEN
36550 C...Call PDFLIB parton distributions.
36554 VALUE(2)=MSTP(53)/1000
36556 VALUE(3)=MOD(MSTP(53),1000)
36557 IF(MINT(93).NE.2000000+MSTP(53)) THEN
36558 CALL PDFSET(PARM,VALUE)
36559 MINT(93)=2000000+MSTP(53)
36562 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
36563 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
36564 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
36582 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
36585 C...Anomalous photon parton distribution call.
36586 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
36589 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
36590 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
36591 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
36592 IF(MSTP(57).EQ.0) Q2MX=P2MX
36594 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36595 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
36597 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
36598 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
36601 ELSEIF(MSTP(56).EQ.1) THEN
36602 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
36603 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
36604 IF(MSTP(57).EQ.0) Q2MX=P2MX
36606 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36607 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
36609 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
36610 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
36613 ELSEIF(MSTP(56).EQ.2) THEN
36614 IF(MSTP(57).EQ.0) Q2MX=P2MX
36615 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
36618 XPVAL(KFL)=VXPGA(KFL)
36621 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
36622 IF(MSTP(57).EQ.0) Q2MX=P2MX
36623 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
36626 XPVAL(KFL)=VXPGA(KFL)
36630 220 RKF=11D0*PYR(0)
36632 IF(RKF.GT.1D0) KFR=2
36633 IF(RKF.GT.5D0) KFR=3
36634 IF(RKF.GT.6D0) KFR=4
36635 IF(RKF.GT.10D0) KFR=5
36636 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
36637 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
36638 IF(MSTP(57).EQ.0) Q2MX=P2MX
36639 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
36642 XPVAL(KFL)=VXPGA(KFL)
36647 C...Proton parton distribution call.
36649 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
36650 CALL PYPDPR(X,Q2,XPPR)
36654 XPVAL(1)=XPQ(1)-XPQ(-1)
36655 XPVAL(2)=XPQ(2)-XPQ(-2)
36656 ELSEIF(MSTP(52).EQ.2) THEN
36657 C...Call PDFLIB parton distributions.
36661 VALUE(2)=MSTP(51)/1000
36663 VALUE(3)=MOD(MSTP(51),1000)
36664 IF(MINT(93).NE.1000000+MSTP(51)) THEN
36665 CALL PDFSET(PARM,VALUE)
36666 MINT(93)=1000000+MSTP(51)
36669 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
36670 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
36671 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
36689 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
36693 C...Isospin average for pi0/gammaVDM.
36694 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
36695 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
36700 XPS=0.5D0*(XPQ(1)+XPQ(-2))
36701 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
36705 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
36706 & XPVAL(3)+XPVAL(4)+XPVAL(5)
36710 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
36711 XPQ(1)=XPQ(1)+0.2D0*XPV
36712 XPQ(2)=XPQ(2)+0.8D0*XPV
36713 XPVAL(1)=0.2D0*XPVL
36714 XPVAL(2)=0.8D0*XPVL
36715 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
36718 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
36721 IF(MSTP(55).GE.9) THEN
36727 XPQ(1)=XPQ(1)+0.5D0*XPV
36728 XPQ(2)=XPQ(2)+0.5D0*XPV
36729 XPVAL(1)=0.5D0*XPVL
36730 XPVAL(2)=0.5D0*XPVL
36734 XPVAL(-KFL)=XPVAL(KFL)
36737 C...Rescale for gammaVDM by effective gamma -> rho coupling.
36738 C+++Do not rescale?
36739 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
36740 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
36742 XPQ(KFL)=VINT(281)*XPQ(KFL)
36743 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
36745 VINT(232)=VINT(281)*XPV
36748 C...Simple recipes for kaons.
36749 ELSEIF(KFA.EQ.321) THEN
36750 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
36752 XPVAL(-3)=XPVAL(-1)
36754 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
36755 XPS=0.5D0*(XPQ(1)+XPQ(-2))
36756 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
36759 XPQ(1)=XPQ(1)+0.5D0*XPV
36760 XPQ(-1)=XPQ(-1)+0.5D0*XPV
36761 XPQ(3)=XPQ(3)+0.5D0*XPV
36762 XPQ(-3)=XPQ(-3)+0.5D0*XPV
36763 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
36767 XPVAL(-1)=0.5D0*XPV
36769 XPVAL(-3)=0.5D0*XPV
36771 C...Isospin conjugation for neutron.
36772 ELSEIF(KFA.EQ.2112) THEN
36783 C...Simple recipes for hyperon (average valence parton distribution).
36784 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
36785 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
36786 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
36787 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
36792 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
36793 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
36794 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
36795 XPV=(XPVAL(1)+XPVAL(2))/3D0
36798 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
36799 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
36800 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
36803 C...Charge conjugation for antiparticle.
36806 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
36813 XPVAL(KFL)=XPVAL(-KFL)
36818 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
36821 C...Only reshape PDFs for the non-first interactions;
36822 C...But need valence/sea separation already from first interaction.
36823 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
36824 KFVSEL=KFIVAL(JS,1)
36825 C...If valence quark kicked out of pi0 or gamma then that decides
36826 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
36827 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
36830 XPVL=XPVL+XPVAL(KFL)
36831 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
36834 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
36835 XPVAL(IABS(KFVSEL))=XPVL
36838 XPVAL(-KFL)=XPVAL(KFL)
36841 C...If valence quark kicked out of K0S or K0S then that decides whether
36842 C...we should consider state as d sbar or s dbar.
36843 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
36845 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
36846 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
36847 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
36848 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
36851 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
36852 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
36853 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
36857 C...XPQ distributions are nominal for a (signed) beam particle
36858 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
36866 IF(IFL.EQ.0) GOTO 350
36868 C...Count up number of original IFL valence quarks.
36870 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
36871 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
36872 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
36873 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
36874 C...bookkeep as if d dbar (for total momentum sum in valence sector).
36875 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
36876 C...Count down number of remaining IFL valence quarks. Skip current
36877 C...interaction initiator.
36879 DO 330 I1=1,NMI(JS)
36880 IF (I1.EQ.MINT(36)) GOTO 330
36881 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
36885 C...Separate out original VALENCE and SEA content.
36887 SEA=MAX(0D0,XPQ(IFL)-VAL)
36891 C...Rescale valence content if changed.
36892 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
36893 & (VAL*IVREM)/IVORG
36895 C...Momentum integrals of original and removed valence quarks.
36896 IF(IVORG.NE.0) THEN
36897 C...For p/n/pbar/nbar beams can split into d_val and u_val.
36898 C...Isospin conjugation for neutrons
36899 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
36901 IF (KFA.EQ.2112) IAFLP=3-IAFLP
36902 VPAVG=PAVG(IAFLP,Q2)
36903 C...For other baryons average d_val and u_val, like for PDFs.
36904 ELSEIF(KFA.GT.1000) THEN
36905 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
36906 C...For mesons and photon average d_val and u_val and scale by 3/2.
36907 C...Very crude, especially for photon.
36909 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
36911 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
36912 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
36915 C...Now add companions (at X with partner having been at Z=XASSOC).
36916 C...NOTE: due to the assumed simple x scaling, the partner was at what
36917 C...corresponds to a higher Z than XASSOC, if there were intermediate
36918 C...scatterings. Nothing done about that for the moment.
36919 DO 340 IVC=1,NVC(JS,IFL)
36920 C...Skip companions that have been kicked out
36921 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
36925 C...Momentum fraction of the partner quark.
36926 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
36927 XS=XASSOC(JS,IFL,IVC)
36930 C...Momentum fraction of the companion quark.
36931 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
36933 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
36934 C...Add to momentum sum, with rescaling compensation factor.
36935 XCFAC=(XREM+XS)/XREM*CMPFAC
36936 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
36941 C...Wait until all flavours treated, then rescale seas and gluon.
36944 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
36945 IF (RSFAC.LE.0D0) THEN
36946 C...First calculate factor needed to exactly restore pz cons.
36947 IF (NRESC.EQ.1) CMPFAC =
36948 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
36949 C...Add a bit of headroom
36951 C...Try a few times if more headroom is needed, then print error message.
36952 IF (NRESC.LE.10) GOTO 345
36954 & '(PYPDFU:) Negative reshaping factor persists!')
36955 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
36959 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
36960 C...Also store resulting distributions in XPQ
36962 DO 360 ISVC=-1,NVC(JS,IFL)
36963 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
36966 C...Save companion reweighting factor for PYPTIS.
36971 C...Allow gluon also in position 21.
36974 C...Check positivity and reset above maximum allowed flavour.
36976 XPQ(KFL)=MAX(0D0,XPQ(KFL))
36977 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
36980 C...Formats for error printouts.
36981 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
36982 5100 FORMAT(' Error: illegal particle code for parton distribution;',
36984 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
36986 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
36987 & ' Removed valence momentum fraction : ',F6.3/
36988 & ' Added companion momentum fraction : ',F6.3/
36989 & ' Resulting rescale factor : ',F6.3)
36991 C...Reset side pointer and return
36997 C*********************************************************************
37000 C...Gives proton parton distribution at small x and/or Q^2 according to
37001 C...correct limiting behaviour.
37003 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37005 C...Double precision and integer declarations.
37006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37007 IMPLICIT INTEGER(I-N)
37008 INTEGER PYK,PYCHGE,PYCOMP
37010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37011 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37012 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37013 COMMON/PYINT1/MINT(400),VINT(400)
37014 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37016 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37017 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37019 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37023 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37024 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37025 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37027 CALL PYPDFU(KF,X,Q2,XPQ)
37031 C...Reset. Check x.
37035 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37036 WRITE(MSTU(11),5000) X
37040 C...Define valence content.
37044 IF(KF.EQ.2212) THEN
37047 ELSEIF(KF.EQ.-2212) THEN
37050 ELSEIF(KF.EQ.2112) THEN
37053 ELSEIF(KF.EQ.-2112) THEN
37056 ELSEIF(KF.EQ.211) THEN
37060 ELSEIF(KF.EQ.-211) THEN
37064 ELSEIF(MINT(105).LE.223) THEN
37069 ELSEIF(MINT(105).EQ.333) THEN
37074 ELSEIF(MINT(105).EQ.443) THEN
37081 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
37083 CALL PYPDFU(KFC,X,Q2,XPA)
37084 Q2MN=MAX(3D0,VINT(231))
37085 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
37086 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
37088 C...Large Q2 and large x: naive call is enough.
37089 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
37095 C...Small Q2 and large x: dampen boundary value.
37096 ELSEIF(X.GT.XMN) THEN
37098 C...Evaluate at boundary and define dampening factors.
37100 CALL PYPDFU(KFC,X,Q2MN,XPA)
37101 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
37102 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
37104 C...Separate valence and sea parts of parton distribution.
37106 XFV1=XPA(KFV1)-XPA(-KFV1)
37107 XPA(KFV1)=XPA(-KFV1)
37108 XFV2=XPA(KFV2)-XPA(-KFV2)
37109 XPA(KFV2)=XPA(-KFV2)
37111 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
37112 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
37113 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
37114 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
37117 C...Dampen valence and sea separately. Put back together.
37119 XPQ(KFL)=FS*XPA(KFL)
37122 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
37123 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
37125 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
37126 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
37127 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
37128 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
37132 C...Large Q2 and small x: interpolate behaviour.
37133 ELSEIF(Q2.GT.Q2MN) THEN
37135 C...Evaluate at extremes and define coefficients for interpolation.
37137 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
37140 CALL PYPDFU(KFC,X,Q2B,XPB)
37142 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
37143 FVA=(X/XMN)**0.45D0*FLA
37144 FSA=(X/XMN)**(-0.08D0)*FLA
37147 C...Separate valence and sea parts of parton distribution.
37149 XFVA1=XPA(KFV1)-XPA(-KFV1)
37150 XPA(KFV1)=XPA(-KFV1)
37151 XFVA2=XPA(KFV2)-XPA(-KFV2)
37152 XPA(KFV2)=XPA(-KFV2)
37153 XFVB1=XPB(KFV1)-XPB(-KFV1)
37154 XPB(KFV1)=XPB(-KFV1)
37155 XFVB2=XPB(KFV2)-XPB(-KFV2)
37156 XPB(KFV2)=XPB(-KFV2)
37158 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
37159 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
37160 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
37161 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
37162 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
37163 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
37164 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
37165 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
37168 C...Interpolate for valence and sea. Put back together.
37170 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
37173 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
37174 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
37176 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
37177 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
37178 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
37179 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
37183 C...Small Q2 and small x: dampen boundary value and add term.
37186 C...Evaluate at boundary and define dampening factors.
37188 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
37189 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
37191 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
37192 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
37193 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
37194 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
37195 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
37196 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
37198 C...Separate valence and sea parts of parton distribution.
37200 XFV1=XPA(KFV1)-XPA(-KFV1)
37201 XPA(KFV1)=XPA(-KFV1)
37202 XFV2=XPA(KFV2)-XPA(-KFV2)
37203 XPA(KFV2)=XPA(-KFV2)
37205 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
37206 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
37207 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
37208 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
37211 C...Dampen valence and sea separately. Add constant terms.
37212 C...Put back together.
37214 XPQ(KFL)=FSA*XPA(KFL)
37218 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
37220 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
37221 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
37224 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
37226 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
37227 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
37228 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
37229 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
37235 C...Format for error printout.
37236 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37241 C*********************************************************************
37244 C...Gives electron (or muon, or tau) parton distribution.
37246 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
37248 C...Double precision and integer declarations.
37249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37250 IMPLICIT INTEGER(I-N)
37251 INTEGER PYK,PYCHGE,PYCOMP
37253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37255 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37256 COMMON/PYINT1/MINT(400),VINT(400)
37257 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37259 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
37261 C...Interface to PDFLIB.
37262 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
37264 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
37265 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
37266 CHARACTER*20 PARM(20)
37267 DATA VALUE/20*0D0/,PARM/20*' '/
37269 C...Some common constants.
37275 IF(KFA.EQ.13) PME=PMAS(13,1)
37276 IF(KFA.EQ.15) PME=PMAS(15,1)
37277 XL=LOG(MAX(1D-10,X))
37278 X1L=LOG(MAX(1D-10,1D0-X))
37279 HLE=LOG(MAX(3D0,Q2/PME**2))
37280 HBE2=(AEM/PARU(1))*(HLE-1D0)
37282 C...Electron inside electron, see R. Kleiss et al., in Z physics at
37283 C...LEP 1, CERN 89-08, p. 34
37284 IF(MSTP(59).LE.1) THEN
37285 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
37286 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
37287 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
37288 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
37289 & 4D0*XL/(1D0-X)-5D0-X)
37291 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
37292 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
37293 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
37295 C...Zero distribution for very large x and rescale it for intermediate.
37296 IF(X.GT.1D0-1D-10) THEN
37298 ELSEIF(X.GT.1D0-1D-7) THEN
37299 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
37303 C...Photon and (transverse) W- inside electron.
37304 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
37305 IF(MSTP(13).LE.1) THEN
37308 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
37310 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
37311 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
37312 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
37314 C...Electron or positron inside photon inside electron.
37315 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
37316 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
37317 & 2D0*X*(1D0+X)*XL)
37318 XPEL(11)=XPEL(11)+XFSEA
37321 C...Initialize PDFLIB photon parton distributions.
37322 IF(MSTP(56).EQ.2) THEN
37326 VALUE(2)=MSTP(55)/1000
37328 VALUE(3)=MOD(MSTP(55),1000)
37329 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37330 CALL PDFSET(PARM,VALUE)
37331 MINT(93)=3000000+MSTP(55)
37335 C...Quarks and gluons inside photon inside electron:
37336 C...numerical convolution required.
37345 IF(ITER.EQ.0) NSTP=2
37347 SXP(KFL)=0.5D0*SXP(KFL)
37350 IF(ITER.EQ.0) WTSTP=0.5D0
37351 C...Pick grid of x_{gamma} values logarithmically even.
37356 XLE=XL*(ISTP-0.5D0)/NSTP
37358 XE=MIN(1D0-1D-10,EXP(XLE))
37359 XG=MIN(1D0-1D-10,X/XE)
37360 C...Evaluate photon inside electron parton distribution for convolution.
37361 XPGP=1D0+(1D0-XE)**2
37362 IF(MSTP(13).LE.1) THEN
37365 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
37367 C...Evaluate photon parton distributions for convolution.
37368 IF(MSTP(56).EQ.1) THEN
37369 IF(MSTP(55).EQ.1) THEN
37370 CALL PYPDGA(XG,Q2,XPGA)
37371 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37374 IF(MSTP(55).GE.7) P2MX=4.0D0
37375 IF(MSTP(57).EQ.0) Q2MX=P2MX
37377 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37378 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37380 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37383 IF(MSTP(55).GE.11) P2MX=4.0D0
37384 IF(MSTP(57).EQ.0) Q2MX=P2MX
37386 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37387 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37391 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
37393 ELSEIF(MSTP(56).EQ.2) THEN
37394 C...Call PDFLIB parton distributions.
37396 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37397 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37398 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37399 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
37400 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
37401 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
37402 SXP(3)=SXP(3)+WTSTP*XPGP*STR
37403 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
37404 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
37405 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
37408 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
37409 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
37410 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
37412 C...Put convolution into output arrays.
37414 XPEL(0)=FCONV*SXP(0)
37416 XPEL(KFL)=FCONV*SXP(KFL)
37417 XPEL(-KFL)=XPEL(KFL)
37424 C*********************************************************************
37427 C...Gives photon parton distribution.
37429 SUBROUTINE PYPDGA(X,Q2,XPGA)
37431 C...Double precision and integer declarations.
37432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37433 IMPLICIT INTEGER(I-N)
37434 INTEGER PYK,PYCHGE,PYCOMP
37436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37437 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37438 COMMON/PYINT1/MINT(400),VINT(400)
37439 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
37441 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
37442 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
37443 &DGCS(4,3),DGDS(4,3),DGES(4,3)
37445 C...The following data lines are coefficients needed in the
37446 C...Drees and Grassie photon parton distribution parametrization.
37447 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
37448 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
37449 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
37450 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
37451 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
37452 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
37453 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
37454 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
37455 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
37456 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
37457 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
37458 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
37459 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
37460 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
37461 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
37462 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
37463 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
37464 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
37465 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
37466 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
37467 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
37468 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
37469 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
37470 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
37471 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
37472 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
37474 C...Photon parton distribution from Drees and Grassie.
37475 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
37480 IF(MSTP(57).LE.0) THEN
37483 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
37487 IF(Q2.GT.25D0) NF=4
37488 IF(Q2.GT.300D0) NF=5
37492 C...Evaluate gluon content.
37493 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
37494 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
37495 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
37496 XPGL=DGA*X**DGB*X1**DGC
37498 C...Evaluate up- and down-type quark content.
37499 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
37500 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
37501 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
37502 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
37503 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
37504 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
37505 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
37506 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
37507 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
37508 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
37509 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
37511 IF(NF.EQ.4) DGF=10D0
37512 IF(NF.EQ.5) DGF=55D0/6D0
37513 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
37515 XPQU=(XPQS+9D0*XPQN)/6D0
37516 XPQD=(XPQS-4.5D0*XPQN)/6D0
37517 ELSEIF(NF.EQ.4) THEN
37518 XPQU=(XPQS+6D0*XPQN)/8D0
37519 XPQD=(XPQS-6D0*XPQN)/8D0
37521 XPQU=(XPQS+7.5D0*XPQN)/10D0
37522 XPQD=(XPQS-5D0*XPQN)/10D0
37525 C...Put into output arrays.
37530 IF(NF.GE.4) XPGA(4)=AEM*XPQU
37531 IF(NF.GE.5) XPGA(5)=AEM*XPQD
37533 XPGA(-KFL)=XPGA(KFL)
37539 C*********************************************************************
37542 C...Constructs the F2 and parton distributions of the photon
37543 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
37544 C...For F2, c and b are included by the Bethe-Heitler formula;
37545 C...in the 'MSbar' scheme additionally a Cgamma term is added.
37546 C...Contains the SaS sets 1D, 1M, 2D and 2M.
37547 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37549 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
37551 C...Double precision and integer declarations.
37552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37553 IMPLICIT INTEGER(I-N)
37554 INTEGER PYK,PYCHGE,PYCOMP
37556 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37558 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37559 SAVE /PYINT8/,/PYINT9/
37561 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
37562 C...Charm and bottom masses (low to compensate for J/psi etc.).
37563 DATA PMC/1.3D0/, PMB/4.6D0/
37564 C...alpha_em and alpha_em/(2*pi).
37565 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
37566 C...Lambda value for 4 flavours.
37568 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
37570 C...VMD couplings f_V**2/(4*pi).
37571 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
37572 C...Masses for rho (=omega) and phi.
37573 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
37574 C...Number of points in integration for IP2=1.
37592 C...Set Q0 cut-off parameter as function of set used.
37600 C...Scale choice for off-shell photon; common factors.
37605 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
37606 FACNOR=LOG(Q2/Q02)/NSTEP
37607 ELSEIF(IP2.EQ.2) THEN
37609 ELSEIF(IP2.EQ.3) THEN
37611 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
37612 ELSEIF(IP2.EQ.4) THEN
37613 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37614 & ((Q2+P2)*(Q02+P2)))
37615 ELSEIF(IP2.EQ.5) THEN
37616 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37617 & ((Q2+P2)*(Q02+P2)))
37618 P2MX=Q0*SQRT(P2MXA)
37619 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
37620 ELSEIF(IP2.EQ.6) THEN
37621 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37622 & ((Q2+P2)*(Q02+P2)))
37623 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
37625 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37626 & ((Q2+P2)*(Q02+P2)))
37627 P2MX=Q0*SQRT(P2MXA)
37629 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
37630 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
37631 IF(ABS(Q2-Q02).GT.1D-6) THEN
37632 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
37633 ELSEIF(P2.LT.Q02) THEN
37634 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
37640 C...Call VMD parametrization for d quark and use to give rho, omega,
37641 C...phi. Note dipole dampening for off-shell photon.
37642 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37646 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
37647 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
37649 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
37651 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
37652 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
37653 XPVMD(3)=XPVMD(3)+FACS*XFVAL
37654 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
37655 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
37656 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
37657 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
37658 VXPVMD(2)=FRACU*FACUD*XFVAL
37659 VXPVMD(3)=FACS*XFVAL
37660 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
37661 VXPVMD(-2)=FRACU*FACUD*XFVAL
37662 VXPVMD(-3)=FACS*XFVAL
37665 C...Anomalous parametrizations for different strategies
37666 C...for off-shell photons; except full integration.
37668 C...Call anomalous parametrization for d + u + s.
37669 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37671 XPANL(KFL)=FACNOR*XPGA(KFL)
37672 VXPANL(KFL)=FACNOR*VXPGA(KFL)
37675 C...Call anomalous parametrization for c and b.
37676 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37678 XPANH(KFL)=FACNOR*XPGA(KFL)
37679 VXPANH(KFL)=FACNOR*VXPGA(KFL)
37681 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37683 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
37684 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
37688 C...Special option: loop over flavours and integrate over k2.
37690 DO 160 ISTEP=1,NSTEP
37691 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
37692 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
37693 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
37694 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
37695 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
37696 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
37697 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
37699 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
37700 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
37701 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
37702 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
37708 C...Call Bethe-Heitler term expression for charm and bottom.
37709 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
37712 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
37716 C...For MSbar subtraction call C^gamma term expression for d, u, s.
37717 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
37718 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
37720 XPDIR(KFL)=XPGA(KFL)
37724 C...Store result in output array.
37727 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
37728 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37729 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
37730 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
37731 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
37737 C*********************************************************************
37740 C...Evaluates the VMD parton distributions of a photon,
37741 C...evolved homogeneously from an initial scale P2 to Q2.
37742 C...Does not include dipole suppression factor.
37743 C...ISET is parton distribution set, see above;
37744 C...additionally ISET=0 is used for the evolution of an anomalous photon
37745 C...which branched at a scale P2 and then evolved homogeneously to Q2.
37746 C...ALAM is the 4-flavour Lambda, which is automatically converted
37747 C...to 3- and 5-flavour equivalents as needed.
37748 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37750 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
37752 C...Double precision and integer declarations.
37753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37754 IMPLICIT INTEGER(I-N)
37755 INTEGER PYK,PYCHGE,PYCOMP
37756 C...Local arrays and data.
37757 DIMENSION XPGA(-6:6), VXPGA(-6:6)
37758 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
37767 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
37768 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
37769 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
37770 P2EFF=MAX(P2,1.2D0*ALAM3**2)
37771 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
37772 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
37773 Q2EFF=MAX(Q2,P2EFF)
37775 C...Find number of flavours at lower and upper scale.
37777 IF(P2EFF.LT.PMC**2) NFP=3
37778 IF(P2EFF.GT.PMB**2) NFP=5
37780 IF(Q2EFF.LT.PMC**2) NFQ=3
37781 IF(Q2EFF.GT.PMB**2) NFQ=5
37783 C...Find s as sum of 3-, 4- and 5-flavour parts.
37787 IF(NFQ.EQ.3) Q2DIV=Q2EFF
37788 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
37790 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
37792 IF(NFP.EQ.3) P2DIV=PMC**2
37794 IF(NFQ.EQ.5) Q2DIV=PMB**2
37795 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
37799 IF(NFP.EQ.5) P2DIV=P2EFF
37800 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
37803 C...Calculate frequent combinations of x and s.
37810 C...Evaluate homogeneous anomalous parton distributions below or
37811 C...above threshold.
37813 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37814 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37815 XVAL = X * 1.5D0 * (X**2+X1**2)
37819 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
37820 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
37821 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
37822 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
37823 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
37824 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
37825 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
37826 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
37827 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
37828 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
37829 & (2D0*X-1D0)*X*XL**2)
37832 C...Evaluate set 1D parton distributions below or above threshold.
37833 ELSEIF(ISET.EQ.1) THEN
37834 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37835 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37836 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
37837 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
37838 XSEA = 0.100D0 * X1**3.76D0
37840 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
37841 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
37842 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
37843 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
37844 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
37845 & X**0.40D0 * X1**(1.76D0+3D0*S)
37846 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
37847 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
37848 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
37849 XSEA0 = 0.100D0 * X1**3.76D0
37852 C...Evaluate set 1M parton distributions below or above threshold.
37853 ELSEIF(ISET.EQ.2) THEN
37854 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37855 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37856 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
37857 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
37860 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
37861 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
37862 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
37863 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
37864 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
37865 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
37866 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
37867 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
37872 C...Evaluate set 2D parton distributions below or above threshold.
37873 ELSEIF(ISET.EQ.3) THEN
37874 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37875 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37876 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
37877 XGLU = 1.925D0 * X1**2
37878 XSEA = 0.242D0 * X1**4
37880 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
37881 & X**(0.46D0+0.25D0*S) *
37882 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
37883 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
37884 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
37885 & EXP(-18.67D0*S) *
37886 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
37887 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
37888 & XL**(9.3D0*S/(1D0+1.7D0*S))
37889 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
37890 & (1D0-0.607D0*S+21.95D0*S2) *
37891 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
37892 XSEA0 = 0.242D0 * X1**4
37895 C...Evaluate set 2M parton distributions below or above threshold.
37896 ELSEIF(ISET.EQ.4) THEN
37897 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37898 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37899 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
37900 XGLU = 1.808D0 * X1**2
37901 XSEA = 0.209D0 * X1**4
37903 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
37904 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
37905 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
37906 & XL**(5.15D0*S/(1D0+2D0*S)) +
37907 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
37908 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
37909 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
37910 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
37911 & XL**(10.9D0*S/(1D0+2.5D0*S))
37912 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
37913 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
37914 & X1**(4D0+S) * XL**(0.45D0*S)
37915 XSEA0 = 0.209D0 * X1**4
37919 C...Threshold factors for c and b sea.
37920 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
37922 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
37923 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
37925 XCHM=XSEA*(1D0-(SCH/SLL)**2)
37927 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
37931 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
37932 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
37934 XBOT=XSEA*(1D0-(SBT/SLL)**2)
37936 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
37940 C...Fill parton distributions.
37947 XPGA(KFA)=XPGA(KFA)+XVAL
37949 XPGA(-KFL)=XPGA(KFL)
37957 C*********************************************************************
37960 C...Evaluates the parton distributions of the anomalous photon,
37961 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
37962 C...KF=0 gives the sum over (up to) 5 flavours,
37963 C...KF<0 limits to flavours up to abs(KF),
37964 C...KF>0 is for flavour KF only.
37965 C...ALAM is the 4-flavour Lambda, which is automatically converted
37966 C...to 3- and 5-flavour equivalents as needed.
37967 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37969 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
37971 C...Double precision and integer declarations.
37972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37973 IMPLICIT INTEGER(I-N)
37974 INTEGER PYK,PYCHGE,PYCOMP
37975 C...Local arrays and data.
37976 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
37977 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
37984 IF(Q2.LE.P2) RETURN
37987 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
37988 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
37990 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
37991 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
37992 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
37993 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
37994 Q2EFF=MAX(Q2,P2EFF)
37997 C...Find number of flavours at lower and upper scale.
37999 IF(P2EFF.LT.PMC**2) NFP=3
38000 IF(P2EFF.GT.PMB**2) NFP=5
38002 IF(Q2EFF.LT.PMC**2) NFQ=3
38003 IF(Q2EFF.GT.PMB**2) NFQ=5
38005 C...Define range of flavour loop.
38009 ELSEIF(KF.LT.0) THEN
38017 C...Loop over flavours the photon can branch into.
38018 DO 110 KFL=KFLMN,KFLMX
38020 C...Light flavours: calculate t range and (approximate) s range.
38021 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38022 TDIFF=LOG(Q2EFF/P2EFF)
38023 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38024 & LOG(P2EFF/ALAMSQ(NFQ)))
38025 IF(NFQ.GT.NFP) THEN
38027 IF(NFQ.EQ.4) Q2DIV=PMC**2
38028 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38029 & LOG(P2EFF/ALAMSQ(NFQ)))
38030 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38031 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38032 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38034 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38036 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38037 & LOG(P2EFF/ALAMSQ(4)))
38038 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38039 & LOG(P2EFF/ALAMSQ(3)))
38040 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38043 C...u and s quark do not need a separate treatment when d has been done.
38044 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38046 C...Charm: as above, but only include range above c threshold.
38047 ELSEIF(KFL.EQ.4) THEN
38048 IF(Q2.LE.PMC**2) GOTO 110
38049 P2EFF=MAX(P2EFF,PMC**2)
38050 Q2EFF=MAX(Q2EFF,P2EFF)
38051 TDIFF=LOG(Q2EFF/P2EFF)
38052 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38053 & LOG(P2EFF/ALAMSQ(NFQ)))
38054 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38056 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38057 & LOG(P2EFF/ALAMSQ(NFQ)))
38058 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38059 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38060 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38063 C...Bottom: as above, but only include range above b threshold.
38064 ELSEIF(KFL.EQ.5) THEN
38065 IF(Q2.LE.PMB**2) GOTO 110
38066 P2EFF=MAX(P2EFF,PMB**2)
38067 Q2EFF=MAX(Q2,P2EFF)
38068 TDIFF=LOG(Q2EFF/P2EFF)
38069 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38070 & LOG(P2EFF/ALAMSQ(NFQ)))
38073 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
38075 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
38076 FAC=AEM2PI*2D0*CHSQ*TDIFF
38078 C...Evaluate parton distributions (normalized to unit momentum sum).
38079 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
38080 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
38081 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
38082 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
38083 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
38084 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
38085 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
38086 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
38087 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
38088 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
38089 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
38090 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
38092 C...Threshold factors for c and b sea.
38093 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38095 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38096 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38097 XCHM=XSEA*(1D0-(SCH/SLL)**3)
38100 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38101 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38102 XBOT=XSEA*(1D0-(SBT/SLL)**3)
38106 C...Add contribution of each valence flavour.
38107 XPGA(0)=XPGA(0)+FAC*XGLU
38108 XPGA(1)=XPGA(1)+FAC*XSEA
38109 XPGA(2)=XPGA(2)+FAC*XSEA
38110 XPGA(3)=XPGA(3)+FAC*XSEA
38111 XPGA(4)=XPGA(4)+FAC*XCHM
38112 XPGA(5)=XPGA(5)+FAC*XBOT
38113 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
38114 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
38117 XPGA(-KFL)=XPGA(KFL)
38118 VXPGA(-KFL)=VXPGA(KFL)
38125 C*********************************************************************
38128 C...Evaluates the Bethe-Heitler cross section for heavy flavour
38130 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38132 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
38134 C...Double precision and integer declarations.
38135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38136 IMPLICIT INTEGER(I-N)
38137 INTEGER PYK,PYCHGE,PYCOMP
38140 DATA AEM2PI/0.0011614D0/
38146 C...Check kinematics limits.
38147 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
38149 BETA2=1D0-4D0*PM2/W2
38150 IF(BETA2.LT.1D-10) RETURN
38154 C...Simple case: P2 = 0.
38155 IF(P2.LT.1D-4) THEN
38156 IF(BETA.LT.0.99D0) THEN
38157 XBL=LOG((1D0+BETA)/(1D0-BETA))
38159 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
38161 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
38162 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
38164 C...Complicated case: P2 > 0, based on approximation of
38165 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
38167 RPQ=1D0-4D0*X**2*P2/Q2
38168 IF(RPQ.GT.1D-10) THEN
38169 RPBE=SQRT(RPQ*BETA2)
38170 IF(RPBE.LT.0.99D0) THEN
38171 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
38172 XBI=2D0*RPBE/(1D0-RPBE**2)
38174 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
38175 XBL=LOG((1D0+RPBE)**2/RPBESN)
38176 XBI=2D0*RPBE/RPBESN
38178 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
38179 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
38180 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
38184 C...Multiply by charge-squared etc. to get parton distribution.
38186 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
38187 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
38192 C*********************************************************************
38195 C...Evaluates the direct contribution, i.e. the C^gamma term,
38196 C...as needed in MSbar parametrizations.
38197 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38199 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
38201 C...Double precision and integer declarations.
38202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38203 IMPLICIT INTEGER(I-N)
38204 INTEGER PYK,PYCHGE,PYCOMP
38205 C...Local array and data.
38206 DIMENSION XPGA(-6:6)
38207 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
38214 C...Evaluate common x-dependent expression.
38215 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
38216 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
38218 C...d, u, s part by simple charge factor.
38219 XPGA(1)=(1D0/9D0)*CGAM
38220 XPGA(2)=(4D0/9D0)*CGAM
38221 XPGA(3)=(1D0/9D0)*CGAM
38223 C...Also fill for antiquarks.
38231 C*********************************************************************
38234 C...Gives pi+ parton distribution according to two different
38235 C...parametrizations.
38237 SUBROUTINE PYPDPI(X,Q2,XPPI)
38239 C...Double precision and integer declarations.
38240 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38241 IMPLICIT INTEGER(I-N)
38242 INTEGER PYK,PYCHGE,PYCOMP
38244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38245 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38246 COMMON/PYINT1/MINT(400),VINT(400)
38247 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38249 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
38251 C...The following data lines are coefficients needed in the
38252 C...Owens pion parton distribution parametrizations, see below.
38253 C...Expansion coefficients for up and down valence quark distributions.
38254 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
38255 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38256 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38257 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
38258 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
38259 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38260 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38261 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
38262 C...Expansion coefficients for gluon distribution.
38263 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
38264 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
38265 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
38266 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
38267 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
38268 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
38269 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
38270 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
38271 C...Expansion coefficients for (up+down+strange) quark sea distribution.
38272 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
38273 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
38274 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
38275 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
38276 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
38277 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
38278 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
38279 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
38280 C...Expansion coefficients for charm quark sea distribution.
38281 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
38282 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
38283 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
38284 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
38285 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
38286 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
38287 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
38288 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
38290 C...Euler's beta function, requires ordinary Gamma function
38291 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
38293 C...Reset output array.
38298 IF(MSTP(53).LE.2) THEN
38299 C...Pion parton distributions from Owens.
38300 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
38302 C...Determine set, Lambda and s expansion variable.
38304 IF(NSET.EQ.1) ALAM=0.2D0
38305 IF(NSET.EQ.2) ALAM=0.4D0
38307 IF(MSTP(57).LE.0) THEN
38310 Q2IN=MIN(2D3,MAX(4D0,Q2))
38311 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
38314 C...Calculate parton distributions.
38317 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
38318 & COW(3,IS,KFL,NSET)*SD**2
38321 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
38323 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
38328 C...Put into output array.
38331 XPPI(2)=XQ(1)+XQ(3)/6D0
38334 XPPI(-1)=XQ(1)+XQ(3)/6D0
38339 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
38340 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
38344 C...Determine s expansion variable and some x expressions.
38346 IF(MSTP(57).LE.0) THEN
38349 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
38350 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
38356 C...Evaluate valence, gluon and sea distributions.
38357 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
38358 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
38359 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
38361 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
38362 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
38364 & (1D0-X)**(0.390D0+1.053D0*SD)
38365 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
38367 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
38369 & XL**(2.538D0-0.763D0*SD)
38370 IF(SD.LE.0.888D0) THEN
38373 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
38375 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
38378 IF(SD.LE.1.351D0) THEN
38381 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
38382 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
38386 C...Put into output array.
38394 XPPI(-KFL)=XPPI(KFL)
38396 XPPI(2)=XPPI(2)+XFVAL
38397 XPPI(-1)=XPPI(-1)+XFVAL
38403 C*********************************************************************
38406 C...Gives proton parton distributions according to a few different
38407 C...parametrizations.
38409 SUBROUTINE PYPDPR(X,Q2,XPPR)
38411 C...Double precision and integer declarations.
38412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38413 IMPLICIT INTEGER(I-N)
38414 INTEGER PYK,PYCHGE,PYCOMP
38416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38417 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38418 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38419 COMMON/PYINT1/MINT(400),VINT(400)
38420 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38421 C...Arrays and data.
38422 DIMENSION XPPR(-6:6),Q2MIN(16)
38423 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
38424 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
38426 C...Reset output array.
38431 C...Common preliminaries.
38432 NSET=MAX(1,MIN(16,MSTP(51)))
38433 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
38434 VINT(231)=Q2MIN(NSET)
38435 IF(MSTP(57).EQ.0) THEN
38438 Q2L=MAX(Q2MIN(NSET),Q2)
38441 IF(NSET.GE.1.AND.NSET.LE.3) THEN
38442 C...Interface to the CTEQ 3 parton distributions.
38443 QRT=SQRT(MAX(1D0,Q2L))
38445 C...Loop over flavours.
38448 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
38449 ELSEIF(I.LE.2) THEN
38450 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
38456 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
38457 C...Interface to the GRV 94 distributions.
38459 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38460 ELSEIF(NSET.EQ.5) THEN
38461 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38463 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38466 C...Put into output array.
38468 XPPR(-1)=0.5D0*(UDB+DEL)
38469 XPPR(-2)=0.5D0*(UDB-DEL)
38473 XPPR(1)=DV+XPPR(-1)
38474 XPPR(2)=UV+XPPR(-2)
38479 ELSEIF(NSET.EQ.7) THEN
38480 C...Interface to the CTEQ 5L parton distributions.
38481 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
38482 C...freezing x*f(x,Q2) at borders.
38483 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
38484 XIN=MAX(1D-6,MIN(1D0,X))
38486 C...Loop over flavours (with u <-> d notation mismatch).
38487 SUMUDB=PYCT5L(-1,XIN,QRT)
38488 RATUDB=PYCT5L(-2,XIN,QRT)
38491 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
38492 ELSEIF(I.EQ.2) THEN
38493 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
38494 ELSEIF(I.EQ.-1) THEN
38495 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
38496 ELSEIF(I.EQ.-2) THEN
38497 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
38499 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
38500 IF(I.LT.0) XPPR(-I)=XPPR(I)
38504 ELSEIF(NSET.EQ.8) THEN
38505 C...Interface to the CTEQ 5M1 parton distributions.
38506 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
38507 XIN=MAX(1D-6,MIN(1D0,X))
38509 C...Loop over flavours (with u <-> d notation mismatch).
38510 SUMUDB=PYCT5M(-1,XIN,QRT)
38511 RATUDB=PYCT5M(-2,XIN,QRT)
38514 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
38515 ELSEIF(I.EQ.2) THEN
38516 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
38517 ELSEIF(I.EQ.-1) THEN
38518 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
38519 ELSEIF(I.EQ.-2) THEN
38520 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
38522 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
38523 IF(I.LT.0) XPPR(-I)=XPPR(I)
38527 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
38528 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
38529 C...obsolete but offers backwards compatibility.
38530 CALL PYPDPO(X,Q2L,XPPR)
38532 C...Symmetric choice for debugging only
38533 ELSEIF(NSET.EQ.16) THEN
38551 C*********************************************************************
38554 C...Gives the CTEQ 3 parton distribution function sets in
38555 C...parametrized form, of October 24, 1994.
38556 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
38557 C...J. Qiu, W.K. Tung and H. Weerts.
38559 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
38561 C...Double precision declaration.
38562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38563 IMPLICIT INTEGER(I-N)
38565 C...Data on Lambda values of fits, minimum Q and quark masses.
38566 DIMENSION ALM(3), QMS(4:6)
38567 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
38568 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
38570 C....Check flavour thresholds. Set up QI for SB.
38573 IF(Q .LE. QMS(IP)) THEN
38582 C...Use "standard lambda" of parametrization program for expansion.
38584 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
38589 C...Expansion for CTEQ3L.
38590 IF(ISET .EQ. 1) THEN
38591 IF(IPRT .EQ. 2) THEN
38592 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
38594 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
38595 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
38596 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
38597 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
38598 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
38599 ELSEIF(IPRT .EQ. 1) THEN
38600 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
38602 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
38603 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
38604 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
38605 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
38606 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
38607 ELSEIF(IPRT .EQ. 0) THEN
38608 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
38610 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
38611 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
38612 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
38613 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
38614 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
38615 ELSEIF(IPRT .EQ. -1) THEN
38616 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
38618 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
38619 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
38620 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
38621 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
38622 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
38623 ELSEIF(IPRT .EQ. -2) THEN
38624 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
38626 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
38627 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
38628 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
38629 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
38630 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
38631 ELSEIF(IPRT .EQ. -3) THEN
38632 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
38634 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
38635 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
38636 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
38637 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
38638 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
38639 ELSEIF(IPRT .EQ. -4) THEN
38640 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
38642 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
38643 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
38644 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
38645 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
38646 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
38647 ELSEIF(IPRT .EQ. -5) THEN
38648 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
38650 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
38651 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
38652 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
38653 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
38654 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
38655 ELSEIF(IPRT .EQ. -6) THEN
38656 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
38658 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
38659 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
38660 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
38661 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
38662 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
38665 C...Expansion for CTEQ3M.
38666 ELSEIF(ISET .EQ. 2) THEN
38667 IF(IPRT .EQ. 2) THEN
38668 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
38670 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
38671 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
38672 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
38673 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
38674 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
38675 ELSEIF(IPRT .EQ. 1) THEN
38676 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
38678 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
38679 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
38680 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
38681 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
38682 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
38683 ELSEIF(IPRT .EQ. 0) THEN
38684 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
38686 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
38687 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
38688 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
38689 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
38690 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
38691 ELSEIF(IPRT .EQ. -1) THEN
38692 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
38694 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
38695 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
38696 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
38697 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
38698 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
38699 ELSEIF(IPRT .EQ. -2) THEN
38700 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
38702 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
38703 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
38704 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
38705 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
38706 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
38707 ELSEIF(IPRT .EQ. -3) THEN
38708 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
38710 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
38711 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
38712 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
38713 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
38714 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
38715 ELSEIF(IPRT .EQ. -4) THEN
38716 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
38718 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
38719 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
38720 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
38721 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
38722 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
38723 ELSEIF(IPRT .EQ. -5) THEN
38724 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
38726 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
38727 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
38728 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
38729 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
38730 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
38731 ELSEIF(IPRT .EQ. -6) THEN
38732 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
38734 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
38735 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
38736 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
38737 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
38738 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
38741 C...Expansion for CTEQ3D.
38742 ELSEIF(ISET .EQ. 3) THEN
38743 IF(IPRT .EQ. 2) THEN
38744 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
38746 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
38747 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
38748 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
38749 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
38750 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
38751 ELSEIF(IPRT .EQ. 1) THEN
38752 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
38754 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
38755 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
38756 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
38757 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
38758 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
38759 ELSEIF(IPRT .EQ. 0) THEN
38760 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
38762 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
38763 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
38764 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
38765 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
38766 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
38767 ELSEIF(IPRT .EQ. -1) THEN
38768 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
38770 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
38771 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
38772 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
38773 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
38774 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
38775 ELSEIF(IPRT .EQ. -2) THEN
38776 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
38778 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
38779 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
38780 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
38781 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
38782 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
38783 ELSEIF(IPRT .EQ. -3) THEN
38784 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
38786 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
38787 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
38788 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
38789 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
38790 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
38791 ELSEIF(IPRT .EQ. -4) THEN
38792 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
38794 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
38795 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
38796 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
38797 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
38798 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
38799 ELSEIF(IPRT .EQ. -5) THEN
38800 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
38802 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
38803 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
38804 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
38805 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
38806 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
38807 ELSEIF(IPRT .EQ. -6) THEN
38808 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
38810 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
38811 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
38812 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
38813 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
38814 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
38818 C...Calculation of x * f(x, Q).
38819 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
38820 & *(LOG(1D0+1D0/X))**A5 )
38825 C*********************************************************************
38828 C...Gives the GRV 94 L (leading order) parton distribution function set
38829 C...in parametrized form.
38830 C...Authors: M. Glueck, E. Reya and A. Vogt.
38832 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38834 C...Double precision declaration.
38835 IMPLICIT DOUBLE PRECISION (A - Z)
38837 C...Common expressions.
38839 LAM2 = 0.2322D0 * 0.2322D0
38840 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38846 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
38847 AKU = 0.590D0 - 0.024D0 * S
38848 BKU = 0.131D0 + 0.063D0 * S
38849 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
38850 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
38851 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
38852 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
38853 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
38856 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
38858 BKD = 0.486D0 + 0.062D0 * S
38859 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
38860 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
38861 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
38862 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
38863 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
38866 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
38867 AKE = 0.409D0 - 0.005D0 * S
38868 BKE = 0.799D0 + 0.071D0 * S
38869 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
38870 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
38872 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
38873 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
38878 AKX = 0.410D0 - 0.232D0 * S
38879 BKX = 0.534D0 - 0.457D0 * S
38880 AGX = 0.890D0 - 0.140D0 * S
38882 CX = 0.320D0 + 0.683D0 * S
38883 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
38884 EX = 4.119D0 + 1.713D0 * S
38885 ESX = 0.682D0 + 2.978D0 * S
38886 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
38893 AKS = 1.798D0 - 0.596D0 * S
38894 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
38895 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
38896 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
38897 EST = 3.981D0 + 1.638D0 * S
38899 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38907 BC = 4.24D0 - 0.804D0 * S
38908 DCT = 3.46D0 - 1.076D0 * S
38909 ECT = 4.61D0 + 1.49D0 * S
38910 ESC = 2.555D0 + 1.961D0 * S
38911 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
38920 DBT = 2.929D0 + 1.396D0 * S
38921 EBT = 4.71D0 + 1.514D0 * S
38922 ESB = 4.02D0 + 1.239D0 * S
38923 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
38928 AKG = 1.742D0 - 0.930D0 * S
38929 BKG = - 0.399D0 * S2
38930 AG = 7.486D0 - 2.185D0 * S
38931 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
38932 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
38933 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
38934 EG = 0.807D0 + 2.005D0 * S
38935 ESG = 3.841D0 + 0.316D0 * S
38936 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
38942 C*********************************************************************
38945 C...Gives the GRV 94 M (MSbar) parton distribution function set
38946 C...in parametrized form.
38947 C...Authors: M. Glueck, E. Reya and A. Vogt.
38949 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38951 C...Double precision declaration.
38952 IMPLICIT DOUBLE PRECISION (A - Z)
38954 C...Common expressions.
38956 LAM2 = 0.248D0 * 0.248D0
38957 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38963 NU = 1.304D0 + 0.863D0 * S
38964 AKU = 0.558D0 - 0.020D0 * S
38966 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
38967 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
38968 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
38969 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
38970 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
38973 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
38974 AKD = 0.270D0 - 0.019D0 * S
38976 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
38977 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
38978 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
38979 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
38980 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
38983 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
38984 AKE = 0.409D0 - 0.007D0 * S
38985 BKE = 0.782D0 + 0.082D0 * S
38986 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
38987 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
38989 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
38990 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
38998 BGX = 3.210D0 - 1.866D0 * S
39000 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39001 EX = 3.077D0 + 1.446D0 * S
39002 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39003 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39010 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39011 AS = -4.329D0 + 1.131D0 * S
39012 BS = 9.568D0 - 1.744D0 * S
39013 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39014 EST = 3.031D0 + 1.639D0 * S
39015 ESS = 5.837D0 + 0.815D0 * S
39016 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39022 AKC = -0.625D0 - 0.523D0 * S
39024 BC = 1.896D0 + 1.616D0 * S
39025 DCT = 4.12D0 + 0.683D0 * S
39026 ECT = 4.36D0 + 1.328D0 * S
39027 ESC = 0.677D0 + 0.679D0 * S
39028 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39034 AKB = - 0.193D0 * S
39037 DBT = 3.447D0 + 0.927D0 * S
39038 EBT = 4.68D0 + 1.259D0 * S
39039 ESB = 1.892D0 + 2.199D0 * S
39040 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39045 AKG = 1.724D0 + 0.157D0 * S
39046 BKG = 0.800D0 + 1.016D0 * S
39047 AG = 7.517D0 - 2.547D0 * S
39048 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39049 CG = 4.039D0 + 1.491D0 * S
39050 DG = 3.404D0 + 0.830D0 * S
39051 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39052 ESG = 3.256D0 - 0.436D0 * S
39053 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39058 C*********************************************************************
39061 C...Gives the GRV 94 D (DIS) parton distribution function set
39062 C...in parametrized form.
39063 C...Authors: M. Glueck, E. Reya and A. Vogt.
39065 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39067 C...Double precision declaration.
39068 IMPLICIT DOUBLE PRECISION (A - Z)
39070 C...Common expressions.
39072 LAM2 = 0.248D0 * 0.248D0
39073 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39079 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
39080 AKU = 0.563D0 - 0.025D0 * S
39081 BKU = 0.054D0 + 0.154D0 * S
39082 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
39083 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
39084 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
39085 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
39086 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39089 ND = 0.156D0 - 0.017D0 * S
39090 AKD = 0.299D0 - 0.022D0 * S
39091 BKD = 0.259D0 - 0.015D0 * S
39092 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
39093 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
39094 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
39095 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
39096 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39099 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
39100 AKE = 0.419D0 - 0.013D0 * S
39101 BKE = 1.064D0 - 0.038D0 * S
39102 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
39103 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
39104 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
39105 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
39106 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39111 AKX = 0.326D0 + 0.150D0 * S
39112 BKX = 0.956D0 + 0.405D0 * S
39114 BGX = 3.794D0 - 2.359D0 * DS
39116 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
39117 EX = 3.049D0 + 1.597D0 * S
39118 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
39119 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39126 AKS = 1.415D0 - 0.641D0 * DS
39127 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
39128 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
39129 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
39130 EST = 4.546D0 + 0.372D0 * S2
39131 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
39132 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39138 AKC = -0.625D0 - 0.523D0 * S
39140 BC = 1.896D0 + 1.616D0 * S
39141 DCT = 4.12D0 + 0.683D0 * S
39142 ECT = 4.36D0 + 1.328D0 * S
39143 ESC = 0.677D0 + 0.679D0 * S
39144 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39150 AKB = - 0.193D0 * S
39153 DBT = 3.447D0 + 0.927D0 * S
39154 EBT = 4.68D0 + 1.259D0 * S
39155 ESB = 1.892D0 + 2.199D0 * S
39156 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39162 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
39163 AG = 25.09D0 - 7.935D0 * S
39164 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
39165 CG = 590.3D0 - 173.8D0 * S
39166 DG = 5.196D0 + 1.857D0 * S
39167 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
39168 ESG = 3.232D0 - 0.542D0 * S
39169 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39174 C*********************************************************************
39177 C...Auxiliary for the GRV 94 parton distribution functions
39178 C...for u and d valence and d-u sea.
39179 C...Authors: M. Glueck, E. Reya and A. Vogt.
39181 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
39183 C...Double precision declaration.
39184 IMPLICIT DOUBLE PRECISION (A - Z)
39188 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
39194 C*********************************************************************
39197 C...Auxiliary for the GRV 94 parton distribution functions
39198 C...for d+u sea and gluon.
39199 C...Authors: M. Glueck, E. Reya and A. Vogt.
39201 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
39203 C...Double precision declaration.
39204 IMPLICIT DOUBLE PRECISION (A - Z)
39208 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
39209 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
39214 C*********************************************************************
39217 C...Auxiliary for the GRV 94 parton distribution functions
39218 C...for s, c and b sea.
39219 C...Authors: M. Glueck, E. Reya and A. Vogt.
39221 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
39223 C...Double precision declaration.
39224 IMPLICIT DOUBLE PRECISION (A - Z)
39232 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
39233 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
39239 C*********************************************************************
39242 C...Auxiliary function for parametrization of CTEQ5L.
39243 C...Author: J. Pumplin 9/99.
39245 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
39246 C...in Parametrized Form
39247 C... September 15, 1999
39249 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
39250 C... CTEQ5 PPARTON DISTRIBUTIONS"
39253 C...The CTEQ5M1 set given here is an updated version of the original
39254 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
39255 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
39256 C...almost all applications.
39257 C...The improvement is in the QCD evolution which is now more
39258 C...accurate, and which agrees completely with the benchmark work
39259 C...of the HERA 96/97 Workshop.
39260 C...The differences between the parametrized and the corresponding
39261 C...table versions (on which it is based) are of similar order as
39262 C...between the two version.
39264 C...!! Because accurate parametrizations over a wide range of (x,Q)
39265 C...is hard to obtain, only the most widely used sets CTEQ5M and
39266 C...CTEQ5L are available in parametrized form for now.
39268 C...These parametrizations were obtained by Jon Pumplin.
39270 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
39271 C -------------------------------------------------------------------
39272 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
39273 C 3 CTEQ5L Leading Order 0.127 192 146
39274 C -------------------------------------------------------------------
39275 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
39276 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
39279 C...The two Iset value are adopted to agree with the standard table
39282 C...Range of validity:
39283 C...The range of (x, Q) covered by this parametrization of the QCD
39284 C...evolved parton distributions is 1E-6 < x < 1 ;
39285 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
39286 C...data only in a subset of that region; and the assumed DGLAP
39287 C...evolution is unlikely to be valid for all of it either.
39289 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
39290 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
39291 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
39292 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
39294 FUNCTION PYCT5L(IFL,X,Q)
39296 C...Double precision declaration.
39297 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39298 IMPLICIT INTEGER(I-N)
39300 PARAMETER (NEX=8, NLF=2)
39301 DIMENSION AM(0:NEX,0:NLF,-5:2)
39302 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
39303 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
39304 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
39305 DIMENSION AF(0:NEX)
39307 DATA MEXVEC( 2) / 8 /
39308 DATA MLFVEC( 2) / 2 /
39309 DATA UT1VEC( 2) / 0.4971265E+01 /
39310 DATA UT2VEC( 2) / -0.1105128E+01 /
39311 DATA ALFVEC( 2) / 0.2987216E+00 /
39312 DATA QMAVEC( 2) / 0.0000000E+00 /
39313 DATA (AM( 0,K, 2),K=0, 2)
39314 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
39315 DATA (AM( 1,K, 2),K=0, 2)
39316 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
39317 DATA (AM( 2,K, 2),K=0, 2)
39318 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
39319 DATA (AM( 3,K, 2),K=0, 2)
39320 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
39321 DATA (AM( 4,K, 2),K=0, 2)
39322 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
39323 DATA (AM( 5,K, 2),K=0, 2)
39324 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
39325 DATA (AM( 6,K, 2),K=0, 2)
39326 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
39327 DATA (AM( 7,K, 2),K=0, 2)
39328 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
39329 DATA (AM( 8,K, 2),K=0, 2)
39330 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
39332 DATA MEXVEC( 1) / 8 /
39333 DATA MLFVEC( 1) / 2 /
39334 DATA UT1VEC( 1) / 0.2612618E+01 /
39335 DATA UT2VEC( 1) / -0.1258304E+06 /
39336 DATA ALFVEC( 1) / 0.3407552E+00 /
39337 DATA QMAVEC( 1) / 0.0000000E+00 /
39338 DATA (AM( 0,K, 1),K=0, 2)
39339 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
39340 DATA (AM( 1,K, 1),K=0, 2)
39341 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
39342 DATA (AM( 2,K, 1),K=0, 2)
39343 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
39344 DATA (AM( 3,K, 1),K=0, 2)
39345 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
39346 DATA (AM( 4,K, 1),K=0, 2)
39347 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
39348 DATA (AM( 5,K, 1),K=0, 2)
39349 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
39350 DATA (AM( 6,K, 1),K=0, 2)
39351 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
39352 DATA (AM( 7,K, 1),K=0, 2)
39353 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
39354 DATA (AM( 8,K, 1),K=0, 2)
39355 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
39357 DATA MEXVEC( 0) / 8 /
39358 DATA MLFVEC( 0) / 2 /
39359 DATA UT1VEC( 0) / -0.4656819E+00 /
39360 DATA UT2VEC( 0) / -0.2742390E+03 /
39361 DATA ALFVEC( 0) / 0.4491863E+00 /
39362 DATA QMAVEC( 0) / 0.0000000E+00 /
39363 DATA (AM( 0,K, 0),K=0, 2)
39364 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
39365 DATA (AM( 1,K, 0),K=0, 2)
39366 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
39367 DATA (AM( 2,K, 0),K=0, 2)
39368 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
39369 DATA (AM( 3,K, 0),K=0, 2)
39370 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
39371 DATA (AM( 4,K, 0),K=0, 2)
39372 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
39373 DATA (AM( 5,K, 0),K=0, 2)
39374 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
39375 DATA (AM( 6,K, 0),K=0, 2)
39376 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
39377 DATA (AM( 7,K, 0),K=0, 2)
39378 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
39379 DATA (AM( 8,K, 0),K=0, 2)
39380 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
39382 DATA MEXVEC(-1) / 8 /
39383 DATA MLFVEC(-1) / 2 /
39384 DATA UT1VEC(-1) / 0.3862583E+01 /
39385 DATA UT2VEC(-1) / -0.1265969E+01 /
39386 DATA ALFVEC(-1) / 0.2457668E+00 /
39387 DATA QMAVEC(-1) / 0.0000000E+00 /
39388 DATA (AM( 0,K,-1),K=0, 2)
39389 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
39390 DATA (AM( 1,K,-1),K=0, 2)
39391 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
39392 DATA (AM( 2,K,-1),K=0, 2)
39393 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
39394 DATA (AM( 3,K,-1),K=0, 2)
39395 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
39396 DATA (AM( 4,K,-1),K=0, 2)
39397 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
39398 DATA (AM( 5,K,-1),K=0, 2)
39399 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
39400 DATA (AM( 6,K,-1),K=0, 2)
39401 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
39402 DATA (AM( 7,K,-1),K=0, 2)
39403 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
39404 DATA (AM( 8,K,-1),K=0, 2)
39405 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
39407 DATA MEXVEC(-2) / 7 /
39408 DATA MLFVEC(-2) / 2 /
39409 DATA UT1VEC(-2) / 0.1895615E+00 /
39410 DATA UT2VEC(-2) / -0.3069097E+01 /
39411 DATA ALFVEC(-2) / 0.5293999E+00 /
39412 DATA QMAVEC(-2) / 0.0000000E+00 /
39413 DATA (AM( 0,K,-2),K=0, 2)
39414 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
39415 DATA (AM( 1,K,-2),K=0, 2)
39416 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
39417 DATA (AM( 2,K,-2),K=0, 2)
39418 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
39419 DATA (AM( 3,K,-2),K=0, 2)
39420 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
39421 DATA (AM( 4,K,-2),K=0, 2)
39422 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
39423 DATA (AM( 5,K,-2),K=0, 2)
39424 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
39425 DATA (AM( 6,K,-2),K=0, 2)
39426 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
39427 DATA (AM( 7,K,-2),K=0, 2)
39428 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
39430 DATA MEXVEC(-3) / 7 /
39431 DATA MLFVEC(-3) / 2 /
39432 DATA UT1VEC(-3) / 0.3753257E+01 /
39433 DATA UT2VEC(-3) / -0.1113085E+01 /
39434 DATA ALFVEC(-3) / 0.3713141E+00 /
39435 DATA QMAVEC(-3) / 0.0000000E+00 /
39436 DATA (AM( 0,K,-3),K=0, 2)
39437 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
39438 DATA (AM( 1,K,-3),K=0, 2)
39439 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
39440 DATA (AM( 2,K,-3),K=0, 2)
39441 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
39442 DATA (AM( 3,K,-3),K=0, 2)
39443 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
39444 DATA (AM( 4,K,-3),K=0, 2)
39445 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
39446 DATA (AM( 5,K,-3),K=0, 2)
39447 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
39448 DATA (AM( 6,K,-3),K=0, 2)
39449 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
39450 DATA (AM( 7,K,-3),K=0, 2)
39451 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
39453 DATA MEXVEC(-4) / 7 /
39454 DATA MLFVEC(-4) / 2 /
39455 DATA UT1VEC(-4) / 0.4400772E+01 /
39456 DATA UT2VEC(-4) / -0.1356116E+01 /
39457 DATA ALFVEC(-4) / 0.3712017E-01 /
39458 DATA QMAVEC(-4) / 0.1300000E+01 /
39459 DATA (AM( 0,K,-4),K=0, 2)
39460 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
39461 DATA (AM( 1,K,-4),K=0, 2)
39462 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
39463 DATA (AM( 2,K,-4),K=0, 2)
39464 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
39465 DATA (AM( 3,K,-4),K=0, 2)
39466 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
39467 DATA (AM( 4,K,-4),K=0, 2)
39468 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
39469 DATA (AM( 5,K,-4),K=0, 2)
39470 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
39471 DATA (AM( 6,K,-4),K=0, 2)
39472 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
39473 DATA (AM( 7,K,-4),K=0, 2)
39474 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
39476 DATA MEXVEC(-5) / 6 /
39477 DATA MLFVEC(-5) / 2 /
39478 DATA UT1VEC(-5) / 0.5562568E+01 /
39479 DATA UT2VEC(-5) / -0.1801317E+01 /
39480 DATA ALFVEC(-5) / 0.4952010E-02 /
39481 DATA QMAVEC(-5) / 0.4500000E+01 /
39482 DATA (AM( 0,K,-5),K=0, 2)
39483 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
39484 DATA (AM( 1,K,-5),K=0, 2)
39485 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
39486 DATA (AM( 2,K,-5),K=0, 2)
39487 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
39488 DATA (AM( 3,K,-5),K=0, 2)
39489 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
39490 DATA (AM( 4,K,-5),K=0, 2)
39491 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
39492 DATA (AM( 5,K,-5),K=0, 2)
39493 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
39494 DATA (AM( 6,K,-5),K=0, 2)
39495 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
39497 IF(Q .LE. QMAVEC(IFL)) THEN
39502 IF(X .GE. 1.D0) THEN
39507 TMP = LOG(Q/ALFVEC(IFL))
39508 IF(TMP .LE. 0.D0) THEN
39520 DO 100 K = 0, MLFVEC(IFL)
39521 AF(I) = AF(I) + SBX*AM(I,K,IFL)
39527 U = LOG(X/0.00001D0)
39529 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
39530 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
39531 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
39532 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
39533 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
39535 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
39537 C...Include threshold factor.
39538 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
39543 C*********************************************************************
39546 C...Auxiliary function for parametrization of CTEQ5M1.
39547 C...Author: J. Pumplin 9/99.
39549 FUNCTION PYCT5M(IFL,X,Q)
39551 C...Double precision declaration.
39552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39553 IMPLICIT INTEGER(I-N)
39555 PARAMETER (NEX=8, NLF=2)
39556 DIMENSION AM(0:NEX,0:NLF,-5:2)
39557 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
39558 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
39559 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
39560 DIMENSION AF(0:NEX)
39562 DATA MEXVEC( 2) / 8 /
39563 DATA MLFVEC( 2) / 2 /
39564 DATA UT1VEC( 2) / 0.5141718E+01 /
39565 DATA UT2VEC( 2) / -0.1346944E+01 /
39566 DATA ALFVEC( 2) / 0.5260555E+00 /
39567 DATA QMAVEC( 2) / 0.0000000E+00 /
39568 DATA (AM( 0,K, 2),K=0, 2)
39569 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
39570 DATA (AM( 1,K, 2),K=0, 2)
39571 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
39572 DATA (AM( 2,K, 2),K=0, 2)
39573 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
39574 DATA (AM( 3,K, 2),K=0, 2)
39575 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
39576 DATA (AM( 4,K, 2),K=0, 2)
39577 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
39578 DATA (AM( 5,K, 2),K=0, 2)
39579 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
39580 DATA (AM( 6,K, 2),K=0, 2)
39581 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
39582 DATA (AM( 7,K, 2),K=0, 2)
39583 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
39584 DATA (AM( 8,K, 2),K=0, 2)
39585 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
39587 DATA MEXVEC( 1) / 8 /
39588 DATA MLFVEC( 1) / 2 /
39589 DATA UT1VEC( 1) / 0.4138426E+01 /
39590 DATA UT2VEC( 1) / -0.3221374E+01 /
39591 DATA ALFVEC( 1) / 0.4960962E+00 /
39592 DATA QMAVEC( 1) / 0.0000000E+00 /
39593 DATA (AM( 0,K, 1),K=0, 2)
39594 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
39595 DATA (AM( 1,K, 1),K=0, 2)
39596 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
39597 DATA (AM( 2,K, 1),K=0, 2)
39598 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
39599 DATA (AM( 3,K, 1),K=0, 2)
39600 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
39601 DATA (AM( 4,K, 1),K=0, 2)
39602 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
39603 DATA (AM( 5,K, 1),K=0, 2)
39604 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
39605 DATA (AM( 6,K, 1),K=0, 2)
39606 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
39607 DATA (AM( 7,K, 1),K=0, 2)
39608 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
39609 DATA (AM( 8,K, 1),K=0, 2)
39610 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
39612 DATA MEXVEC( 0) / 8 /
39613 DATA MLFVEC( 0) / 2 /
39614 DATA UT1VEC( 0) / -0.1026789E+01 /
39615 DATA UT2VEC( 0) / -0.9051707E+01 /
39616 DATA ALFVEC( 0) / 0.9462977E+00 /
39617 DATA QMAVEC( 0) / 0.0000000E+00 /
39618 DATA (AM( 0,K, 0),K=0, 2)
39619 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
39620 DATA (AM( 1,K, 0),K=0, 2)
39621 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
39622 DATA (AM( 2,K, 0),K=0, 2)
39623 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
39624 DATA (AM( 3,K, 0),K=0, 2)
39625 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
39626 DATA (AM( 4,K, 0),K=0, 2)
39627 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
39628 DATA (AM( 5,K, 0),K=0, 2)
39629 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
39630 DATA (AM( 6,K, 0),K=0, 2)
39631 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
39632 DATA (AM( 7,K, 0),K=0, 2)
39633 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
39634 DATA (AM( 8,K, 0),K=0, 2)
39635 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
39637 DATA MEXVEC(-1) / 8 /
39638 DATA MLFVEC(-1) / 2 /
39639 DATA UT1VEC(-1) / 0.5243571E+01 /
39640 DATA UT2VEC(-1) / -0.2870513E+01 /
39641 DATA ALFVEC(-1) / 0.6701448E+00 /
39642 DATA QMAVEC(-1) / 0.0000000E+00 /
39643 DATA (AM( 0,K,-1),K=0, 2)
39644 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
39645 DATA (AM( 1,K,-1),K=0, 2)
39646 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
39647 DATA (AM( 2,K,-1),K=0, 2)
39648 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
39649 DATA (AM( 3,K,-1),K=0, 2)
39650 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
39651 DATA (AM( 4,K,-1),K=0, 2)
39652 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
39653 DATA (AM( 5,K,-1),K=0, 2)
39654 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
39655 DATA (AM( 6,K,-1),K=0, 2)
39656 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
39657 DATA (AM( 7,K,-1),K=0, 2)
39658 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
39659 DATA (AM( 8,K,-1),K=0, 2)
39660 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
39662 DATA MEXVEC(-2) / 7 /
39663 DATA MLFVEC(-2) / 2 /
39664 DATA UT1VEC(-2) / 0.4782210E+01 /
39665 DATA UT2VEC(-2) / -0.1976856E+02 /
39666 DATA ALFVEC(-2) / 0.7558374E+00 /
39667 DATA QMAVEC(-2) / 0.0000000E+00 /
39668 DATA (AM( 0,K,-2),K=0, 2)
39669 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
39670 DATA (AM( 1,K,-2),K=0, 2)
39671 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
39672 DATA (AM( 2,K,-2),K=0, 2)
39673 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
39674 DATA (AM( 3,K,-2),K=0, 2)
39675 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
39676 DATA (AM( 4,K,-2),K=0, 2)
39677 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
39678 DATA (AM( 5,K,-2),K=0, 2)
39679 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
39680 DATA (AM( 6,K,-2),K=0, 2)
39681 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
39682 DATA (AM( 7,K,-2),K=0, 2)
39683 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
39685 DATA MEXVEC(-3) / 7 /
39686 DATA MLFVEC(-3) / 2 /
39687 DATA UT1VEC(-3) / 0.4518239E+01 /
39688 DATA UT2VEC(-3) / -0.2690590E+01 /
39689 DATA ALFVEC(-3) / 0.6124079E+00 /
39690 DATA QMAVEC(-3) / 0.0000000E+00 /
39691 DATA (AM( 0,K,-3),K=0, 2)
39692 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
39693 DATA (AM( 1,K,-3),K=0, 2)
39694 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
39695 DATA (AM( 2,K,-3),K=0, 2)
39696 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
39697 DATA (AM( 3,K,-3),K=0, 2)
39698 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
39699 DATA (AM( 4,K,-3),K=0, 2)
39700 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
39701 DATA (AM( 5,K,-3),K=0, 2)
39702 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
39703 DATA (AM( 6,K,-3),K=0, 2)
39704 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
39705 DATA (AM( 7,K,-3),K=0, 2)
39706 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
39708 DATA MEXVEC(-4) / 7 /
39709 DATA MLFVEC(-4) / 2 /
39710 DATA UT1VEC(-4) / 0.2783230E+01 /
39711 DATA UT2VEC(-4) / -0.1746328E+01 /
39712 DATA ALFVEC(-4) / 0.1115653E+01 /
39713 DATA QMAVEC(-4) / 0.1300000E+01 /
39714 DATA (AM( 0,K,-4),K=0, 2)
39715 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
39716 DATA (AM( 1,K,-4),K=0, 2)
39717 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
39718 DATA (AM( 2,K,-4),K=0, 2)
39719 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
39720 DATA (AM( 3,K,-4),K=0, 2)
39721 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
39722 DATA (AM( 4,K,-4),K=0, 2)
39723 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
39724 DATA (AM( 5,K,-4),K=0, 2)
39725 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
39726 DATA (AM( 6,K,-4),K=0, 2)
39727 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
39728 DATA (AM( 7,K,-4),K=0, 2)
39729 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
39731 DATA MEXVEC(-5) / 6 /
39732 DATA MLFVEC(-5) / 2 /
39733 DATA UT1VEC(-5) / 0.1619654E+02 /
39734 DATA UT2VEC(-5) / -0.3367346E+01 /
39735 DATA ALFVEC(-5) / 0.5109891E-02 /
39736 DATA QMAVEC(-5) / 0.4500000E+01 /
39737 DATA (AM( 0,K,-5),K=0, 2)
39738 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
39739 DATA (AM( 1,K,-5),K=0, 2)
39740 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
39741 DATA (AM( 2,K,-5),K=0, 2)
39742 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
39743 DATA (AM( 3,K,-5),K=0, 2)
39744 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
39745 DATA (AM( 4,K,-5),K=0, 2)
39746 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
39747 DATA (AM( 5,K,-5),K=0, 2)
39748 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
39749 DATA (AM( 6,K,-5),K=0, 2)
39750 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
39752 IF(Q .LE. QMAVEC(IFL)) THEN
39757 IF(X .GE. 1.D0) THEN
39762 TMP = LOG(Q/ALFVEC(IFL))
39763 IF(TMP .LE. 0.D0) THEN
39775 DO 100 K = 0, MLFVEC(IFL)
39776 AF(I) = AF(I) + SBX*AM(I,K,IFL)
39782 U = LOG(X/0.00001D0)
39784 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
39785 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
39786 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
39787 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
39788 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
39790 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
39792 C...Include threshold factor.
39793 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
39798 C*********************************************************************
39801 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
39802 C...a few older parametrizations, now obsolete but convenient for
39803 C...backwards checks.
39805 SUBROUTINE PYPDPO(X,Q2,XPPR)
39807 C...Double precision and integer declarations.
39808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39809 IMPLICIT INTEGER(I-N)
39810 INTEGER PYK,PYCHGE,PYCOMP
39812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39813 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39814 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39815 COMMON/PYINT1/MINT(400),VINT(400)
39816 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39817 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
39818 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
39821 C...The following data lines are coefficients needed in the
39822 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
39823 C...parametrizations, see below.
39824 C...Powers of 1-x in different cases.
39825 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
39826 C...Expansion coefficients for up valence quark distribution.
39827 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
39828 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
39829 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
39830 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
39831 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
39832 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
39833 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
39834 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
39835 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
39836 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
39837 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
39838 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
39839 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
39840 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
39841 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
39842 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
39843 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
39844 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
39845 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
39846 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
39847 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
39848 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
39849 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
39850 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
39851 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
39852 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
39853 C...Expansion coefficients for down valence quark distribution.
39854 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
39855 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
39856 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
39857 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
39858 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
39859 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
39860 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
39861 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
39862 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
39863 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
39864 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
39865 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
39866 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
39867 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
39868 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
39869 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
39870 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
39871 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
39872 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
39873 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
39874 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
39875 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
39876 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
39877 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
39878 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
39879 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
39880 C...Expansion coefficients for up and down sea quark distributions.
39881 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
39882 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
39883 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
39884 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
39885 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
39886 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
39887 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
39888 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
39889 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
39890 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
39891 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
39892 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
39893 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
39894 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
39895 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
39896 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
39897 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
39898 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
39899 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
39900 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
39901 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
39902 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
39903 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
39904 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
39905 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
39906 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
39907 C...Expansion coefficients for gluon distribution.
39908 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
39909 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
39910 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
39911 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
39912 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
39913 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
39914 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
39915 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
39916 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
39917 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
39918 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
39919 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
39920 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
39921 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
39922 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
39923 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
39924 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
39925 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
39926 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
39927 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
39928 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
39929 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
39930 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
39931 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
39932 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
39933 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
39934 C...Expansion coefficients for strange sea quark distribution.
39935 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
39936 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
39937 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
39938 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
39939 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
39940 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
39941 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
39942 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
39943 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
39944 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
39945 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
39946 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
39947 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
39948 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
39949 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
39950 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
39951 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
39952 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
39953 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
39954 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
39955 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
39956 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
39957 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
39958 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
39959 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
39960 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
39961 C...Expansion coefficients for charm sea quark distribution.
39962 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
39963 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
39964 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
39965 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
39966 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
39967 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
39968 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
39969 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
39970 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
39971 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
39972 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
39973 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
39974 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
39975 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
39976 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
39977 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
39978 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
39979 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
39980 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
39981 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
39982 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
39983 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
39984 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
39985 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
39986 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
39987 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
39988 C...Expansion coefficients for bottom sea quark distribution.
39989 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
39990 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
39991 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
39992 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
39993 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
39994 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
39995 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
39996 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
39997 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
39998 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
39999 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40000 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40001 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40002 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40003 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40004 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40005 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40006 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40007 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40008 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40009 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40010 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40011 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40012 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40013 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40014 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40015 C...Expansion coefficients for top sea quark distribution.
40016 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40017 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40018 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40019 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40020 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40021 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40022 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40023 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40024 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40025 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40026 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40027 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40028 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40029 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40030 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40031 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40032 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40033 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40034 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40035 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40036 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40037 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40038 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40039 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40040 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40041 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40043 C...The following data lines are coefficients needed in the
40044 C...Duke, Owens proton structure function parametrizations, see below.
40045 C...Expansion coefficients for (up+down) valence quark distribution.
40046 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40047 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40048 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40049 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40050 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40051 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40052 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40053 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40054 C...Expansion coefficients for down valence quark distribution.
40055 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40056 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40057 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40058 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40059 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40060 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40061 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40062 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40063 C...Expansion coefficients for (up+down+strange) sea quark distribution.
40064 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40065 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40066 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40067 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
40068 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
40069 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40070 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
40071 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
40072 C...Expansion coefficients for charm sea quark distribution.
40073 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
40074 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40075 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
40076 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
40077 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
40078 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40079 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
40080 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
40081 C...Expansion coefficients for gluon distribution.
40082 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
40083 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40084 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
40085 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
40086 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
40087 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40088 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
40089 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
40091 C...Euler's beta function, requires ordinary Gamma function
40092 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40094 C...Leading order proton parton distributions from Glueck, Reya and
40095 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40097 IF(MSTP(51).EQ.11) THEN
40099 C...Determine s expansion variable and some x expressions.
40100 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40101 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40106 C...Evaluate valence, gluon and sea distributions.
40107 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
40108 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
40109 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
40110 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
40111 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
40112 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
40113 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
40114 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
40115 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
40116 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
40117 & SQRT(4.066D0*SD**1.218D0*XL)))*
40118 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
40119 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
40120 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
40121 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
40122 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
40123 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
40124 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
40125 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
40126 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
40127 IF(SD.LE.0.888D0) THEN
40130 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
40131 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
40132 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
40134 IF(SD.LE.1.351D0) THEN
40137 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
40138 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
40139 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
40142 C...Put into output array.
40144 XPPR(1)=XFVDD+XFSEA
40145 XPPR(2)=XFVUD-XFVDD+XFSEA
40155 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
40156 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
40157 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
40159 C...Determine set, Lambda and x and t expansion variables.
40161 IF(NSET.EQ.1) ALAM=0.2D0
40162 IF(NSET.EQ.2) ALAM=0.29D0
40163 TMIN=LOG(5D0/ALAM**2)
40164 TMAX=LOG(1D8/ALAM**2)
40165 T=LOG(MAX(1D0,Q2/ALAM**2))
40166 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40168 IF(X.LE.0.1D0) NX=2
40169 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
40170 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
40172 C...Chebyshev polynomials for x and t expansion.
40175 TX(3)=2D0*VX**2-1D0
40176 TX(4)=4D0*VX**3-3D0*VX
40177 TX(5)=8D0*VX**4-8D0*VX**2+1D0
40178 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
40181 TT(3)=2D0*VT**2-1D0
40182 TT(4)=4D0*VT**3-3D0*VT
40183 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40184 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40186 C...Calculate structure functions.
40191 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
40194 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
40197 C...Put into output array.
40199 XPPR(1)=XQ(2)+XQ(3)
40200 XPPR(2)=XQ(1)+XQ(3)
40208 C...Special expansion for bottom (threshold effects).
40209 IF(MSTP(58).GE.5) THEN
40210 IF(NSET.EQ.1) TMIN=8.1905D0
40211 IF(NSET.EQ.2) TMIN=7.4474D0
40213 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40216 TT(3)=2D0*VT**2-1D0
40217 TT(4)=4D0*VT**3-3D0*VT
40218 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40219 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40223 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
40226 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
40231 C...Special expansion for top (threshold effects).
40232 IF(MSTP(58).GE.6) THEN
40233 IF(NSET.EQ.1) TMIN=11.5528D0
40234 IF(NSET.EQ.2) TMIN=10.8097D0
40235 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
40236 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
40238 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40241 TT(3)=2D0*VT**2-1D0
40242 TT(4)=4D0*VT**3-3D0*VT
40243 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40244 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40248 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
40251 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
40256 C...Proton parton distributions from Duke, Owens.
40257 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
40258 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
40260 C...Determine set, Lambda and s expansion parameter.
40262 IF(NSET.EQ.1) ALAM=0.2D0
40263 IF(NSET.EQ.2) ALAM=0.4D0
40264 Q2IN=MIN(1D6,MAX(4D0,Q2))
40265 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40267 C...Calculate structure functions.
40270 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
40271 & CDO(3,IS,KFL,NSET)*SD**2
40274 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
40275 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
40277 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40278 & TS(5)*X**2+TS(6)*X**3)
40282 C...Put into output arrays.
40284 XPPR(1)=XQ(2)+XQ(3)/6D0
40285 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
40298 C*********************************************************************
40301 C...Gives threshold attractive/repulsive factor for heavy flavour
40304 FUNCTION PYHFTH(SH,SQM,FRATT)
40306 C...Double precision and integer declarations.
40307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40308 IMPLICIT INTEGER(I-N)
40309 INTEGER PYK,PYCHGE,PYCOMP
40311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40312 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40313 COMMON/PYINT1/MINT(400),VINT(400)
40314 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40316 C...Value for alpha_strong.
40317 IF(MSTP(35).LE.1) THEN
40322 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
40328 C...Evaluate attractive and repulsive factors.
40329 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
40330 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
40331 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
40332 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
40333 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
40339 C*********************************************************************
40342 C...Splits a hadron remnant into two (partons or hadron + parton)
40343 C...in case it is more complicated than just a quark or a diquark.
40345 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
40347 C...Double precision and integer declarations.
40348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40349 IMPLICIT INTEGER(I-N)
40350 INTEGER PYK,PYCHGE,PYCOMP
40351 C...Commonblocks. PYDAT1 temporary
40352 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40353 COMMON/PYINT1/MINT(400),VINT(400)
40354 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40355 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
40359 C...Preliminaries. Parton composition.
40362 KFL(1)=MOD(KFA/1000,10)
40363 KFL(2)=MOD(KFA/100,10)
40364 KFL(3)=MOD(KFA/10,10)
40365 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
40366 KFL(2)=INT(1.5D0+PYR(0))
40367 IF(MINT(105).EQ.333) KFL(2)=3
40368 IF(MINT(105).EQ.443) KFL(2)=4
40370 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
40373 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
40376 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
40377 KFL(2)=MOD(KFA/10,10)
40378 KFL(3)=MOD(KFA/100,10)
40380 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
40387 C...Subdivide lepton.
40388 IF(KFA.GE.11.AND.KFA.LE.18) THEN
40389 IF(KFLR.EQ.KFA) THEN
40391 ELSEIF(KFLR.EQ.22) THEN
40393 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
40395 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
40397 ELSEIF(KFLR.EQ.21) THEN
40405 C...Subdivide photon.
40406 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
40407 IF(KFLR.NE.21) THEN
40412 IF(RAGR.GT.0.125D0) KFLSP=2
40413 IF(RAGR.GT.0.625D0) KFLSP=3
40414 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
40418 C...Subdivide Reggeon or Pomeron.
40419 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
40420 IF(KFLIN.EQ.21) THEN
40426 C...Subdivide meson.
40427 ELSEIF(KFL(1).EQ.0) THEN
40428 KFL(2)=KFL(2)*(-1)**KFL(2)
40429 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
40430 IF(KFLR.EQ.KFL(2)) THEN
40432 ELSEIF(KFLR.EQ.KFL(3)) THEN
40434 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
40437 ELSEIF(KFLR.EQ.21) THEN
40440 ELSEIF(KFLR*KFL(2).GT.0) THEN
40443 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
40444 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40446 ELSEIF(KFLCH.EQ.0) THEN
40447 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40455 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
40456 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40458 ELSEIF(KFLCH.EQ.0) THEN
40459 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40466 C...Subdivide baryon.
40470 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
40473 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
40476 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
40477 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
40480 IAGR=1.00001D0+2.99998D0*PYR(0)
40483 IF(IAGR.EQ.1) ID1=2
40484 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
40487 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
40488 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
40489 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
40490 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
40491 ELSEIF(MOD(KFA,10).EQ.2) THEN
40492 IF(IAGR.EQ.1) KSP=1
40493 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
40495 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
40496 IF(KFLR.EQ.21) THEN
40498 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
40501 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
40502 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40504 ELSEIF(KFLCH.EQ.0) THEN
40505 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40509 ELSEIF(NAGR.EQ.0) THEN
40512 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
40513 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40515 ELSEIF(KFLCH.EQ.0) THEN
40516 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40524 C...Add on correct sign for result.
40531 C*********************************************************************
40534 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
40535 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
40536 C...(Dover, 1965) 6.1.36.
40540 C...Double precision and integer declarations.
40541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40542 IMPLICIT INTEGER(I-N)
40543 INTEGER PYK,PYCHGE,PYCOMP
40544 C...Local array and data.
40546 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
40547 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
40556 PYGAMM=PYGAMM+B(I)*DXP
40562 PYGAMM=(X-IX)*PYGAMM
40569 C***********************************************************************
40572 C...Calculates real and imaginary parts of the auxiliary functions W1
40573 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
40574 C...der Bij, Nucl. Phys. B297 (1988) 221.
40576 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
40578 C...Double precision and integer declarations.
40579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40580 IMPLICIT INTEGER(I-N)
40581 INTEGER PYK,PYCHGE,PYCOMP
40583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40586 ASINH(X)=LOG(X+SQRT(X**2+1D0))
40587 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
40589 IF(EPS.LT.0D0) THEN
40590 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
40591 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
40593 ELSEIF(EPS.LT.1D0) THEN
40594 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
40595 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
40596 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
40597 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
40599 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
40600 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
40607 C***********************************************************************
40610 C...Calculates real and imaginary parts of the auxiliary function I3;
40611 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
40612 C...Nucl. Phys. B297 (1988) 221.
40614 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
40616 C...Double precision and integer declarations.
40617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40618 IMPLICIT INTEGER(I-N)
40619 INTEGER PYK,PYCHGE,PYCOMP
40621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40624 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
40625 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
40627 IF(EPS.LT.0D0) THEN
40628 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40629 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
40630 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
40631 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
40632 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
40633 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
40634 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
40635 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
40637 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
40638 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
40639 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
40640 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
40641 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
40642 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
40643 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
40644 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
40645 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40646 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
40647 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
40648 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
40649 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
40650 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
40651 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
40652 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
40654 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
40655 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
40656 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
40657 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
40658 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
40661 ELSEIF(EPS.LT.1D0) THEN
40662 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40663 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
40664 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
40665 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
40666 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
40667 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
40668 & (0.25D0*(RAT+1D0)*EPS))
40669 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
40670 & (0.25D0*(RAT+1D0)*EPS))
40671 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
40672 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
40673 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
40674 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
40675 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
40676 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
40677 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
40678 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
40679 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40680 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
40681 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
40682 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
40683 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
40684 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
40685 & (1D0+0.25D0*RAT*EPS-GA))
40686 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
40687 & (1D0+0.25D0*RAT*EPS-GA))
40689 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
40690 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
40691 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
40692 & LOG((GA+BE-1D0)/(BE-GA))
40693 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
40696 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
40697 RCTHE=RSQ*(1D0-2D0*BE/EPS)
40698 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
40699 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
40700 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
40702 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
40703 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
40704 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
40705 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
40706 & (PHI-THE)*(PHI+THE-PARU(1))
40707 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
40708 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
40711 Y3RE=2D0/(2D0*BE-1D0)*F3RE
40712 Y3IM=2D0/(2D0*BE-1D0)*F3IM
40717 C***********************************************************************
40720 C...Calculates real and imaginary part of Spence function; see
40721 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
40723 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
40725 C...Double precision and integer declarations.
40726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40727 IMPLICIT INTEGER(I-N)
40728 INTEGER PYK,PYCHGE,PYCOMP
40730 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40732 C...Local array and data.
40735 &1.000000D+00, -5.000000D-01, 1.666667D-01,
40736 &0.000000D+00, -3.333333D-02, 0.000000D+00,
40737 &2.380952D-02, 0.000000D+00, -3.333333D-02,
40738 &0.000000D+00, 7.575757D-02, 0.000000D+00,
40739 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
40743 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
40744 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
40745 IF(IREIM.EQ.2) PYSPEN=0D0
40749 XMOD=SQRT(XRE**2+XIM**2)
40750 IF(XMOD.LT.1D-6) THEN
40751 IF(IREIM.EQ.1) PYSPEN=0D0
40752 IF(IREIM.EQ.2) PYSPEN=0D0
40756 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40760 IF(XMOD.GT.1D0) THEN
40762 ALGXIM=XARG-SIGN(PARU(1),XARG)
40763 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
40764 SP0IM=-ALGXRE*ALGXIM
40771 IF(XRE.GT.0.5D0) THEN
40776 XMOD=SQRT(XRE**2+XIM**2)
40777 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40780 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
40781 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
40787 XMOD=SQRT(XRE**2+XIM**2)
40788 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40797 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
40798 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
40799 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
40802 SPRE=SPRE+B(I)*TERMRE
40803 SPIM=SPIM+B(I)*TERMIM
40806 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
40807 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
40812 C***********************************************************************
40815 C...Calculates the matrix element for the processes
40816 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
40817 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
40818 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
40820 SUBROUTINE PYQQBH(WTQQBH)
40822 C...Double precision and integer declarations.
40823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40824 IMPLICIT INTEGER(I-N)
40825 INTEGER PYK,PYCHGE,PYCOMP
40827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40828 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40829 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40830 COMMON/PYINT1/MINT(400),VINT(400)
40831 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
40832 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
40833 C...Local arrays and function.
40834 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
40835 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
40838 C...Mass parameters.
40841 SHPR=SQRT(VINT(26))*VINT(1)
40842 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
40843 PH=SQRT(VINT(21))*VINT(1)
40847 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
40849 PT=SQRT(MAX(0D0,VINT(197+5*I)))
40850 PP(I,1)=PT*COS(VINT(198+5*I))
40851 PP(I,2)=PT*SIN(VINT(198+5*I))
40853 PP(3,1)=-PP(1,1)-PP(2,1)
40854 PP(3,2)=-PP(1,2)-PP(2,2)
40855 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
40856 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
40857 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
40859 PP(3,3)=PMT3*SINH(VINT(211))
40860 PP(3,4)=PMT3*COSH(VINT(211))
40861 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
40862 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
40863 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
40864 PP(2,3)=-PP(1,3)-PP(3,3)
40865 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
40866 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
40868 C...Set up incoming kinematics and derived momentum combinations.
40872 PP(I,3)=-0.5D0*SHPR*(-1)**I
40873 PP(I,4)=-0.5D0*SHPR
40876 PP(6,J)=PP(1,J)+PP(2,J)
40877 PP(7,J)=PP(1,J)+PP(3,J)
40878 PP(8,J)=PP(1,J)+PP(4,J)
40879 PP(9,J)=PP(1,J)+PP(5,J)
40880 PP(10,J)=-PP(2,J)-PP(3,J)
40881 PP(11,J)=-PP(2,J)-PP(4,J)
40882 PP(12,J)=-PP(2,J)-PP(5,J)
40883 PP(13,J)=-PP(4,J)-PP(5,J)
40886 C...Derived kinematics invariants.
40915 C...Define colour coefficients for g + g -> Q + Qbar + H.
40916 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
40920 CLR(I+3,J+3)=16D0/3D0
40921 CLR(I,J+3)=-2D0/3D0
40922 CLR(I+3,J)=-2D0/3D0
40935 CLR(6+K1,6+K2)=12D0
40939 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
40940 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
40941 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
40942 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
40943 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
40944 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
40945 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
40947 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
40948 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
40949 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
40950 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
40951 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
40952 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
40953 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
40954 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
40955 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
40956 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
40957 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
40958 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
40959 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
40960 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
40961 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
40962 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
40963 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
40964 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
40966 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
40967 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
40968 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
40969 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
40970 & +X4*X9*X5+X4*X5**2)
40971 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
40972 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
40973 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
40974 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
40975 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
40976 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
40977 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
40978 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
40979 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
40980 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
40981 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
40982 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
40983 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
40984 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
40985 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
40986 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
40987 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
40988 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
40989 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
40990 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
40992 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
40993 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
40994 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
40995 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
40996 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
40997 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
40998 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41000 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41001 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41002 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41003 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41004 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41005 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41007 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41008 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41009 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41010 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41011 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41012 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41013 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41015 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41016 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41017 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41018 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41019 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41020 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41021 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41022 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41023 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41024 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41025 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41026 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41027 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41028 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41029 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41030 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41031 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41032 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41033 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41034 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41035 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41036 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41037 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41038 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41039 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41040 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41041 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41042 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41043 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41044 & +X3*X8*X5+X3*X5**2)
41045 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41046 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41047 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41048 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41049 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41050 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41051 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41053 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41054 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41055 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41056 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41057 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41058 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41059 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41060 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41061 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
41062 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
41063 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
41064 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
41065 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
41066 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
41067 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
41068 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
41069 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
41070 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
41071 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
41072 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
41073 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
41074 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
41075 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
41076 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
41077 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
41078 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
41080 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
41081 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
41082 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41083 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
41084 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
41085 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
41086 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
41087 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
41088 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
41089 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
41090 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
41091 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
41092 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
41093 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
41094 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
41095 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
41096 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
41097 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
41098 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
41099 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
41100 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
41101 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
41102 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
41103 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
41104 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
41105 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
41107 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
41108 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
41109 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
41110 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
41111 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
41112 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
41113 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
41114 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
41115 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
41116 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
41117 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
41118 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
41119 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
41120 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
41121 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
41122 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
41123 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
41124 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
41125 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
41126 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
41127 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
41128 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
41129 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
41130 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
41131 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
41132 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
41133 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
41134 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
41135 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
41136 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
41137 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
41138 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
41139 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
41140 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
41141 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
41142 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
41143 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
41144 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
41145 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
41146 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
41147 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
41148 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
41149 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
41150 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
41152 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
41153 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
41154 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
41155 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
41156 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
41157 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
41158 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
41159 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
41160 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
41161 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
41162 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
41164 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
41165 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
41166 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
41167 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
41168 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
41169 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
41171 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
41172 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
41173 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
41175 FM(9,10)=0.5D0*(FMXX+FM(9,10))
41176 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
41177 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
41178 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
41180 C...Repackage matrix elements.
41186 RM(7,7)=FM(7,7)-2D0*FM(9,9)
41187 RM(7,8)=FM(7,8)-2D0*FM(9,10)
41188 RM(8,8)=FM(8,8)-2D0*FM(10,10)
41190 C...Produce final result: matrix elements * colours * propagators.
41195 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
41198 WTQQBH=-WTQQBH/256D0
41201 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
41202 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
41203 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
41205 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
41206 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
41207 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
41209 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
41210 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
41213 C...Produce final result: matrix elements * propagators.
41215 A12=A12/(DX(7)*DX(8))
41217 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
41223 C*********************************************************************
41225 C...PYSTBH (and auxiliaries)
41226 C.. Evaluates the matrix elements for t + b + H production.
41228 SUBROUTINE PYSTBH(WTTBH)
41230 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
41231 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41232 IMPLICIT INTEGER(I-N)
41233 INTEGER PYK,PYCHGE,PYCOMP
41236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41237 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41239 COMMON/PYINT1/MINT(400),VINT(400)
41240 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41241 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
41242 COMMON/PYINT4/MWID(500),WIDS(500,5)
41243 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41244 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41245 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
41246 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
41247 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
41248 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
41249 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41250 DOUBLE PRECISION MW2
41251 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
41252 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
41254 C...LOCAL ARRAYS AND COMPLEX VARIABLES
41255 DIMENSION QQ(4,2),PP(4,3)
41260 C...KINEMATIC PARAMETERS.
41261 SHPR=SQRT(VINT(26))*VINT(1)
41262 PH=SQRT(VINT(21))*VINT(1)
41265 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
41267 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41268 PP(1,I)=PT*COS(VINT(198+5*I))
41269 PP(2,I)=PT*SIN(VINT(198+5*I))
41271 PP(1,3)=-PP(1,1)-PP(1,2)
41272 PP(2,3)=-PP(2,1)-PP(2,2)
41273 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
41274 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
41275 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
41277 PP(3,3)=PMT3*SINH(VINT(211))
41278 PP(4,3)=PMT3*COSH(VINT(211))
41279 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
41280 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41281 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
41282 PP(3,2)=-PP(3,1)-PP(3,3)
41283 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
41284 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
41286 C...CM SYSTEM, INGOING QUARKS/GLUONS
41287 QQ(3,1) = SHPR/2.D0
41292 C...PARAMETERS FOR AMPLITUDE METHOD
41296 MW2 = PMAS(24,1)**2
41299 RMB=PYMRUN(5,VINT(52))
41303 IF (ISUB.EQ.401) THEN
41304 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
41305 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
41306 ELSE IF (ISUB.EQ.402) THEN
41307 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
41308 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
41313 C------------------------------------------------------------------
41314 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
41315 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
41316 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41317 IMPLICIT INTEGER(I-N)
41318 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
41319 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41322 C TOP WIDTH CALCULATION
41329 IF (MT .LT. (MHP+MB)) THEN
41331 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
41332 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
41333 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
41336 C T ->BW +T ->B H^+
41337 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
41338 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
41339 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
41341 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
41342 & -4.D0*(MHP*MB/MT**2)**2 )
41343 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
41344 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
41345 GAMT = GAMTBW+GAMTBH
41352 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
41353 C GG->TBH^+, QQBAR->TBH^+
41354 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
41355 C (FOR INSTANCE WITH PYTHIA)
41356 C------------------------------------------------------------
41357 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
41358 C PHYS REV. D 60 (1999) 115011
41359 C (THESE FILES PREPARED BY J.-L. KNEUR)
41360 C------------------------------------------------------------
41362 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
41364 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
41366 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
41367 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
41368 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
41369 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
41370 C "PHYSICAL PARAMETERS" INPUT:
41371 C MT,MB TOP AND BOTTOM MASSES;
41372 C MHP CHARGED HIGGS MASS
41373 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
41375 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
41376 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
41377 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
41378 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
41379 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
41380 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
41381 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
41383 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41384 IMPLICIT INTEGER(I-N)
41385 DOUBLE PRECISION MW2,MT,MB,MHP,MW
41386 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
41387 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41388 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41389 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41391 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41392 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
41393 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
41394 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
41395 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
41396 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
41397 C (TAN BETA) VALUES
41399 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
41400 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
41405 C COLLECTING THE RELEVANT OVERALL FACTORS:
41406 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
41407 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
41408 C COUPLING CONSTANT (OVERALL NORMALIZATION)
41409 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
41410 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
41411 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
41412 C ALPHAS IS ALPHA_STRONG;
41413 C SW2 IS SIN(THETA_W)**2.
41416 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
41418 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
41419 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
41420 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
41422 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
41423 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
41425 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
41427 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
41428 S = 2*PYTBHS(Q1,Q2)
41435 C TOP WIDTH CALCULATION
41436 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
41437 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
41438 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
41439 A1INV= S -2*P1Q1 -2*P1Q2
41440 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
41441 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
41442 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
41444 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
41445 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
41446 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
41447 C NOW COMES THE AMP**2:
41448 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
41449 C THE EXPRESSIONS BELOW
41452 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
41453 &512*A1*A2*MB*MT/3-
41454 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
41455 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
41456 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
41457 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
41458 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
41459 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
41460 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
41461 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
41462 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
41463 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
41464 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
41465 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
41466 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
41467 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
41468 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
41469 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
41470 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
41471 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
41472 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
41473 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
41474 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
41475 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
41476 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
41477 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
41478 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
41479 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
41480 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
41481 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
41482 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
41483 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
41484 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
41485 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
41486 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
41487 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
41488 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
41489 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
41490 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
41491 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
41492 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
41493 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
41494 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
41495 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
41496 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
41497 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
41498 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
41499 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
41500 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
41501 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
41502 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
41503 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
41504 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
41505 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
41506 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
41507 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
41508 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
41509 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
41510 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
41511 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
41512 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
41513 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
41514 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
41515 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
41516 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
41517 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
41518 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
41519 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
41520 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
41521 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
41522 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
41523 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
41524 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
41525 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
41526 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
41527 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
41528 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
41529 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
41530 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
41531 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
41532 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
41533 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
41534 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
41535 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
41536 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
41537 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
41538 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
41539 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
41540 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
41541 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
41542 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
41543 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41544 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41545 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41546 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
41547 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
41548 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
41549 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
41550 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
41551 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
41552 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
41553 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
41554 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
41555 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
41556 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
41557 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
41558 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
41559 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
41560 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
41561 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
41562 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
41563 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
41564 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
41565 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
41566 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
41567 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
41568 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
41569 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
41570 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
41571 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
41572 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
41573 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
41574 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
41575 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
41576 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
41577 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
41578 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
41579 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
41580 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
41581 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
41582 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
41583 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
41584 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
41585 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
41586 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
41587 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
41588 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
41589 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
41590 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
41591 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
41592 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
41593 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
41594 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
41595 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
41596 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
41597 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
41598 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
41599 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
41600 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
41601 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
41602 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
41603 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
41604 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
41605 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
41606 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41607 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41608 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41609 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
41610 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
41611 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
41612 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
41613 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
41614 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
41615 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
41616 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
41617 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
41618 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
41619 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
41620 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
41621 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
41622 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
41623 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
41624 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
41625 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
41626 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
41627 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
41628 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
41629 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
41630 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
41631 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
41632 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
41633 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
41634 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
41635 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
41636 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
41637 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
41638 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
41639 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
41640 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
41641 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
41642 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
41643 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
41644 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
41645 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
41646 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
41647 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
41648 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
41649 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
41650 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
41651 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
41652 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
41653 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
41654 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
41655 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
41656 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
41657 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
41658 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
41659 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
41660 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
41661 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
41662 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
41663 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
41664 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
41665 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
41666 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
41667 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
41668 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
41669 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
41670 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
41671 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
41672 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
41673 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
41674 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
41675 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
41676 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
41677 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
41678 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
41679 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
41680 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
41681 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
41682 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
41683 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
41684 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
41685 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
41686 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
41687 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
41688 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
41689 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
41690 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
41691 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
41692 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
41693 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
41694 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
41695 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
41696 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
41697 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41698 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41699 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41700 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
41701 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
41702 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
41703 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
41704 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
41705 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
41706 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
41707 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
41708 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
41709 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
41710 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
41711 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
41712 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
41713 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
41714 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
41715 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
41716 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
41717 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
41718 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
41719 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
41720 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
41721 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
41722 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
41723 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
41724 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
41725 &384*A12*MB*MT*P1Q1**2/S**2+
41726 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
41727 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
41728 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
41729 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
41730 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
41731 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
41732 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
41733 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
41734 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
41735 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
41736 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
41737 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
41738 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
41739 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
41740 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
41741 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
41742 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
41743 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
41744 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
41745 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
41746 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
41747 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
41748 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
41749 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
41750 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
41751 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
41752 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
41753 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
41754 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
41755 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
41756 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
41757 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
41758 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
41759 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
41760 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
41761 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
41762 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
41763 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
41764 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
41765 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
41766 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
41767 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
41768 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
41769 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
41770 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
41771 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
41772 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
41773 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
41774 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
41775 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
41776 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
41777 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
41778 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
41779 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
41780 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
41781 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
41782 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
41783 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
41784 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
41785 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
41786 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
41787 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
41788 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
41789 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
41790 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
41791 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
41792 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
41793 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
41794 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
41795 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
41796 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
41797 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
41798 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
41799 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
41800 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
41801 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
41802 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
41803 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
41804 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
41805 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
41806 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
41807 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
41808 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
41809 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
41810 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
41811 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
41812 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
41813 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
41814 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
41815 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
41816 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
41817 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
41818 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
41819 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
41820 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
41821 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
41822 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
41823 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
41824 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
41825 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
41826 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
41827 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
41828 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
41829 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
41830 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
41831 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
41832 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
41833 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
41834 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
41835 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
41836 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
41837 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
41838 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
41839 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
41840 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
41841 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
41842 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
41843 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
41844 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
41845 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
41846 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
41847 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41848 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41849 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41850 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41851 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41852 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41853 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
41854 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
41855 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
41856 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
41857 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
41858 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
41859 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
41860 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
41861 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
41862 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
41863 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
41864 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
41865 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
41866 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
41867 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
41868 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
41869 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
41870 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
41871 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
41872 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
41873 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
41874 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
41875 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
41876 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
41877 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
41878 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
41879 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
41880 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
41881 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
41882 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
41883 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
41884 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
41885 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
41886 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
41887 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
41888 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
41889 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
41890 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
41891 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
41892 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
41893 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
41894 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
41895 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
41896 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
41897 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
41898 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
41899 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
41900 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
41901 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
41904 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41905 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41906 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41907 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41908 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
41909 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
41910 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
41911 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
41912 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
41913 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
41914 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
41915 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
41916 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
41917 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
41918 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
41919 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
41920 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
41921 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
41922 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
41923 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
41924 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
41925 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
41926 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
41927 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
41928 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
41929 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
41930 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
41931 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
41932 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
41933 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
41934 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
41935 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
41936 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
41937 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
41938 &272*A1*A2*P1Q1*S/(3*P1Q2)+
41939 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
41940 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
41941 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
41942 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
41943 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
41944 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
41945 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
41946 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
41947 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
41948 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
41949 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
41950 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
41951 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
41952 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
41953 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
41954 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
41955 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
41956 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
41957 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
41958 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
41959 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
41960 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
41961 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
41962 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
41963 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
41964 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
41965 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
41966 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
41967 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
41968 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
41969 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
41970 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
41971 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
41972 &32*A12*P2Q1*S/(3*P1Q1)-
41973 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
41974 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
41975 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
41976 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
41977 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
41978 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
41979 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
41980 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
41981 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
41982 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
41983 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
41984 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
41985 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
41986 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
41987 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
41988 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
41989 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
41990 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
41991 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
41992 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
41993 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
41994 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
41995 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
41996 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
41997 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
41998 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
41999 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42000 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42001 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42002 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42003 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42004 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42005 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42006 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42007 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42008 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42009 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42010 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42011 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42012 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42013 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42014 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42015 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42016 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42017 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42018 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42019 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42020 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42021 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42022 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42023 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42024 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42025 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42026 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42027 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42028 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42029 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42030 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42031 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42032 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42033 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42034 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42035 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42036 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42037 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42038 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42039 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42040 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42041 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42042 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42043 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42044 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42045 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42046 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42049 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42050 &512*A1*A2*MB*MT/3+
42051 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42052 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42053 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42054 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42055 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42056 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42057 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42058 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42059 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42060 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42061 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
42062 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
42063 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42064 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42065 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
42066 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
42067 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
42068 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
42069 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42070 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
42071 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
42072 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42073 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42074 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42075 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
42076 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42077 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42078 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42079 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42080 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42081 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
42082 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42083 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42084 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
42085 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
42086 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42087 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
42088 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42089 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42090 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
42091 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
42092 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42093 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
42094 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42095 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42096 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42097 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42098 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
42099 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
42100 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42101 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
42102 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42103 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
42104 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
42105 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42106 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42107 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
42108 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
42109 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
42110 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42111 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42112 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42113 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
42114 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42115 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
42116 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42117 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42118 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42119 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
42120 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42121 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
42122 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42123 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42124 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42125 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42126 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42127 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42128 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
42129 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42130 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42131 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
42132 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42133 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42134 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42135 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
42136 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42137 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42138 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
42139 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42140 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42141 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
42142 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42143 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42144 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42145 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
42146 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42147 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42148 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42149 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
42150 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42151 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42152 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42153 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42154 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42155 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
42156 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42157 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
42158 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42159 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
42160 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
42161 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42162 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42163 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42164 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42165 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
42166 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42167 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42168 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42169 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42170 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42171 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
42172 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42173 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42174 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42175 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42176 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42177 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
42178 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
42179 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42180 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42181 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42182 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
42183 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42184 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42185 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42186 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42187 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42188 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
42189 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42190 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
42191 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42192 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42193 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
42194 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42195 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
42196 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
42197 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42198 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42199 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42200 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42201 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42202 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42203 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42204 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
42205 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42206 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42207 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
42208 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42209 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42210 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
42211 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42212 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42213 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
42214 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42215 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42216 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
42217 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42218 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42219 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42220 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
42221 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42222 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
42223 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42224 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42225 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42226 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42227 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42228 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42229 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42230 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42231 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42232 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42233 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42234 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42235 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42236 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42237 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42238 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42239 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42240 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
42241 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42242 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42243 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42244 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
42245 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42246 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42247 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
42248 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42249 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42250 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42251 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42252 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42253 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42254 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42255 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42256 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42257 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42258 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42259 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42260 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42261 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
42262 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42263 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42264 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42265 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42266 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42267 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
42268 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42269 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42270 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42271 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42272 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42273 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42274 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42275 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42276 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
42277 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42278 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42279 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42280 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42281 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42282 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42283 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42284 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42285 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
42286 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42287 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42288 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42289 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42290 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42291 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
42292 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42293 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42294 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
42295 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42296 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42297 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42298 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42299 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42300 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
42301 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42302 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42303 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42304 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42305 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42306 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42307 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42308 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42309 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
42310 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42311 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42312 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42313 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42314 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42315 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42316 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42317 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
42318 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42319 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42320 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42321 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
42322 &384*A12*MB*MT*P1Q1**2/S**2+
42323 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42324 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
42325 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42326 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42327 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42328 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42329 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
42330 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42331 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42332 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42333 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42334 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42335 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42336 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42337 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
42338 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
42339 &384*A2**2*MB*MT*P2Q2**2/S**2+
42340 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42341 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
42342 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
42343 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
42344 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
42345 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
42346 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42347 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
42348 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
42349 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
42350 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
42351 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
42352 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
42353 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42354 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
42355 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42356 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
42357 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42358 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42359 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
42360 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
42361 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
42362 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
42363 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42364 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42365 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42366 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42367 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
42368 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42369 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
42370 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
42371 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
42372 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
42373 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
42374 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42375 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
42376 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42377 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
42378 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42379 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42380 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42381 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
42382 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42383 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42384 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42385 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42386 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
42387 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
42388 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
42389 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
42390 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
42391 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42392 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42393 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42394 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
42395 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42396 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
42397 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42398 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42399 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42400 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42401 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42402 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42403 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
42404 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42405 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
42406 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42407 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
42408 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42409 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42410 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
42411 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
42412 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42413 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42414 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42415 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42416 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
42417 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42418 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
42419 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42420 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
42421 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42422 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
42423 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42424 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
42425 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42426 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
42427 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
42428 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
42429 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42430 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
42431 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
42432 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42433 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42434 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42435 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42436 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
42437 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42438 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42439 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
42440 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
42441 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
42442 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42443 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42444 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42445 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42446 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42447 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42448 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42449 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42450 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42451 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
42452 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42453 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
42454 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42455 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42456 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
42457 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
42458 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42459 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
42460 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42461 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
42462 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
42463 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42464 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42465 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
42466 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42467 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42468 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
42469 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42470 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42471 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42472 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
42473 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
42474 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42475 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
42476 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42477 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42478 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42479 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42480 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42481 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42482 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
42483 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
42484 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
42485 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42486 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42487 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42488 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
42489 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42490 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
42491 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
42492 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42493 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42494 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42495 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42496 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42497 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42498 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42499 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42500 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42501 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42502 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42503 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
42504 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42505 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42506 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42507 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
42508 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42509 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42510 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
42511 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42512 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
42513 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
42514 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42515 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42516 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42517 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42518 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42519 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42520 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
42521 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
42522 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42523 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42524 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
42525 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
42526 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42527 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
42528 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
42529 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
42530 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
42531 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42532 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
42535 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42536 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42537 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42538 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42539 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42540 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
42541 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42542 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42543 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
42544 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42545 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
42546 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
42547 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42548 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42549 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
42550 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
42551 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
42553 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42554 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
42555 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42556 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
42557 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42558 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42559 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42560 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42561 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42562 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
42563 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42564 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
42565 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
42566 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42567 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
42568 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
42569 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
42570 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42571 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42572 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42573 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42574 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42575 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
42576 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42577 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42578 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
42579 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42580 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42581 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
42582 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
42583 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42584 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
42585 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42586 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42587 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
42588 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42589 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
42590 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42591 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
42592 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42593 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42594 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42595 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42596 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42597 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
42598 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
42599 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42600 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
42601 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
42602 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
42603 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
42604 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42605 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42606 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42607 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42608 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42609 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42610 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42611 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42612 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42613 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42614 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
42615 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
42616 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
42617 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42618 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
42619 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42620 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42621 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42622 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42623 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42624 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42625 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42626 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
42627 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42628 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42629 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42630 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
42631 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
42632 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42633 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42634 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
42635 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
42636 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42637 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42638 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42642 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
42643 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
42644 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42645 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42646 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
42647 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
42648 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42649 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
42650 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
42651 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
42652 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42653 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42654 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
42655 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
42656 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
42657 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
42658 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
42659 V910=V910+96*A1*A2*P1P2*P2Q1/S-
42660 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
42661 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
42662 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
42663 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
42664 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
42666 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
42667 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
42668 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42669 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42670 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
42671 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
42672 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42673 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
42674 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
42675 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
42676 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42677 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42678 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
42679 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
42680 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
42681 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
42682 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
42683 A910=A910+96*A1*A2*P1P2*P2Q1/S-
42684 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
42685 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
42686 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
42687 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
42688 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
42692 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
42695 C---------------------------------------------------------
42696 C 2) Q QBAR ->TBH^+
42697 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42699 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
42700 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
42701 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42702 IMPLICIT INTEGER(I-N)
42703 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42704 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42705 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42706 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42707 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42708 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42709 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42710 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42711 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42712 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42713 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
42715 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42716 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42723 C COLLECTING THE RELEVANT OVERALL FACTORS:
42724 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
42725 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
42726 C COUPLING CONSTANT (OVERALL NORMALIZATION)
42727 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42728 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42729 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42730 C ALPHAS IS ALPHA_STRONG;
42731 C SW2 IS SIN(THETA_W)**2.
42734 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42736 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42737 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42738 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42740 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42741 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42743 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42745 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42746 S = 2*PYTBHS(Q1,Q2)
42753 C TOP WIDTH CALCULATION
42754 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42755 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42756 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42757 A1INV= S -2*P1Q1 -2*P1Q2
42758 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42759 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42760 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
42761 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42762 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42763 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42764 C NOW COMES THE AMP**2:
42765 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
42766 C THE EXPRESSIONS BELOW
42767 YY(1, 1) = -16*A**2*A2**2*MB*MT+
42768 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
42769 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
42770 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
42771 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42772 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42773 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
42774 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
42775 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
42776 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
42777 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
42778 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
42779 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
42780 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
42781 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
42782 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
42783 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
42784 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
42785 &32*A2**2*MB**2*P1P2*V**2/S+
42786 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
42787 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
42788 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
42789 YY(1, 1)=2*YY(1, 1)
42791 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
42792 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
42793 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42794 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42795 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
42796 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
42797 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
42798 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42799 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
42800 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
42801 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
42802 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42803 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
42804 &64*A**2*A1*A2*MB*MT*P1P2/S+
42805 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
42806 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
42807 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
42808 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
42809 &64*A**2*A1*A2*P1Q1*P2Q1/S-
42810 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
42811 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
42812 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
42813 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
42814 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
42815 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
42816 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
42817 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
42818 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
42819 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
42820 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
42821 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
42822 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
42823 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
42824 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
42825 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
42826 &32*A1*A2*P1P2*P1Q1*V**2/S+
42827 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
42828 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
42829 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
42830 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
42833 YY(2, 2) =-16*A**2*A12*MB*MT+
42834 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
42835 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
42836 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
42837 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
42838 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
42839 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
42840 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
42841 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
42842 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
42843 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
42844 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
42845 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
42846 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
42847 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
42848 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
42849 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
42850 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
42851 &32*A12*MT**2*P2Q2*V**2/S-
42852 &32*A12*P1Q2*P2Q2*V**2/S
42853 YY(2, 2)=2*YY(2, 2)
42855 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
42856 AMP2= FACT*PS*VTB**2*RES
42859 C=====================================================================
42860 C ************* FUNCTION SCALAR PRODUCTS *************************
42861 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
42862 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42863 IMPLICIT INTEGER(I-N)
42864 DIMENSION A(4),B(4)
42867 DUM=DUM-A(ID)*B(ID)
42873 C*********************************************************************
42876 C...Initializes supersymmetry: finds sparticle masses and
42877 C...branching ratios and stores this information.
42878 C...AUTHOR: STEPHEN MRENNA
42879 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
42883 C...Double precision and integer declarations.
42884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42885 IMPLICIT INTEGER(I-N)
42886 INTEGER PYK,PYCHGE,PYCOMP
42887 C...Parameter statement to help give large particle numbers.
42888 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42889 &KEXCIT=4000000,KDIMEN=5000000)
42891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42893 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
42894 COMMON/PYDAT4/CHAF(500,2)
42896 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42897 COMMON/PYINT4/MWID(500),WIDS(500,5)
42898 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42899 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42900 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42901 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42902 COMMON/PYHTRI/HHH(7)
42903 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
42904 &/PYMSSM/,/PYMSRV/,/PYSSMT/
42906 C...Local variables.
42907 DOUBLE PRECISION ALFA,BETA
42908 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
42909 INTEGER I,J,J1,I1,K1
42910 INTEGER KC,LKNT,IDLAM(400,3)
42911 DOUBLE PRECISION XLAM(0:400)
42912 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
42913 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
42914 DOUBLE PRECISION DELM,XMDIF
42915 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
42916 DOUBLE PRECISION ARG,SGNMU,R
42919 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
42922 &1000001,2000001,1000002,2000002,1000003,2000003,
42923 &1000004,2000004,1000005,2000005,1000006,2000006,
42924 &1000011,2000011,1000012,2000012,1000013,2000013,
42925 &1000014,2000014,1000015,2000015,1000016,2000016,
42926 &1000021,1000022,1000023,1000025,1000035,1000024,
42927 &1000037,1000039, 25, 35, 36, 37,
42928 & 6, 24, 45, 46,1000045, 9*0/
42931 C...Do nothing if SUSY not requested.
42933 IF(IMSSM.EQ.0) RETURN
42935 C...Save copy of MWID(KC) and MDCY(KC,1) values before
42936 C...they are set to zero for the LSP.
42943 MDCYSU(I)=MDCY(KC,1)
42947 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
42951 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
42953 MDCY(KC,1)=MDCYSU(I)
42957 C...First part of routine: set masses and couplings.
42959 C...Reset mixing values in sfermion sector to pure left/right.
42967 C...Add NMSSM states if NMSSM switched on, and change old names.
42968 IF (IMSS(13).NE.0) THEN
42969 C... Switch on NMSSM
42970 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43000 DO 123 KCT=100,MSTU(6)
43001 IF(KCHG(KCT,4).GT.100) KCN=KCT
43007 C... Set stable for now
43013 CHAF(KCN,1)='~chi_50'
43017 C...Read spectrum from SLHA file.
43018 IF (IMSSM.EQ.11.AND.IMSS(21).NE.0) THEN
43019 C...First check for new states
43020 CALL PYSLHA(0,0,IFAIL)
43021 C...Then read spectrum
43022 CALL PYSLHA(1,0,IFAIL)
43023 ELSEIF (IMSS(21).NE.0) THEN
43024 C...Check for new states but don't read spectrum
43025 CALL PYSLHA(0,0,IFAIL)
43028 C...Common couplings.
43033 COS2B=COS(2D0*BETA)
43039 C...Define sparticle masses for a general MSSM simulation.
43040 IF(IMSSM.EQ.1) THEN
43041 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43043 KC=PYCOMP(KSUSY1+I)
43044 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43045 KC=PYCOMP(KSUSY2+I)
43046 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43047 KC=PYCOMP(KSUSY1+I+1)
43048 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43049 KC=PYCOMP(KSUSY2+I+1)
43050 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43052 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43053 IF(XARG.LT.0D0) THEN
43054 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43055 & ' FROM THE SUM RULE. '
43056 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43062 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
43063 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
43064 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
43065 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
43067 IF(IMSS(8).EQ.1) THEN
43072 C...Alternatively derive masses from SUGRA relations.
43073 ELSEIF(IMSSM.EQ.2) THEN
43077 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
43086 C...Add in extra D-term contributions.
43087 IF(IMSS(7).EQ.1) THEN
43092 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43093 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
43094 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
43095 WRITE(MSTU(11),*) 'C DX = ',DX
43096 WRITE(MSTU(11),*) 'C DY = ',DY
43097 WRITE(MSTU(11),*) 'C DS = ',DS
43098 WRITE(MSTU(11),*) 'C '
43099 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
43100 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
43101 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43102 DQ2=DY/6D0-DX/3D0-DS/3D0
43103 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
43104 DD2=DY/3D0+DX-2D0*DS/3D0
43105 DL2=-DY/2D0+DX-2D0*DS/3D0
43106 DE2=DY-DX/3D0-DS/3D0
43107 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
43108 DHD2=-DY/2D0-2D0*DX/3D0+DS
43109 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
43111 DMA2 = 2D0*DMU2+DHU2+DHD2
43113 KC=PYCOMP(KSUSY1+I)
43114 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
43115 KC=PYCOMP(KSUSY2+I)
43116 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
43117 KC=PYCOMP(KSUSY1+I+1)
43118 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
43119 KC=PYCOMP(KSUSY2+I+1)
43120 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
43123 KC=PYCOMP(KSUSY1+I)
43124 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
43125 KC=PYCOMP(KSUSY2+I)
43126 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
43127 KC=PYCOMP(KSUSY1+I+1)
43128 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
43130 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
43131 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
43134 SGNMU=SIGN(1D0,RMSS(4))
43135 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
43136 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
43137 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
43138 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
43139 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
43140 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
43141 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
43142 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
43143 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
43144 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
43145 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
43146 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
43147 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
43150 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
43151 RMSS(6)=SQRT(RMSS(6)**2+DL2)
43152 RMSS(7)=SQRT(RMSS(7)**2+DE2)
43153 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
43154 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
43155 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
43156 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
43157 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
43160 C...Fix the third generation sfermions.
43163 C...Fix the neutralino--chargino--gluino sector.
43166 C...Fix the Higgs sector.
43169 C...Choose the Gunion-Haber convention.
43173 C...Print information on mass parameters.
43174 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
43175 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43176 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
43177 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
43178 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
43179 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
43180 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
43181 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
43182 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
43183 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
43184 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43186 IF(IMSS(20).EQ.1) THEN
43187 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43188 WRITE(MSTU(11),*) ' DEBUG MODE '
43189 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
43190 & UMIX(2,1),UMIX(2,2)
43191 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
43192 & UMIXI(2,1),UMIXI(2,2)
43193 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
43194 & VMIX(2,1),VMIX(2,2)
43195 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
43196 & VMIXI(2,1),VMIXI(2,2)
43197 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
43198 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
43199 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
43200 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
43201 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
43202 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
43203 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
43204 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
43205 WRITE(MSTU(11),*) ' ALFA = ',ALFA
43206 WRITE(MSTU(11),*) ' BETA = ',BETA
43207 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
43208 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
43209 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43212 C...Set up the Higgs couplings - needed here since initialization
43213 C...in PYINRE did not yet occur when PYWIDT is called below.
43225 C2B=COSB**2-SINB**2
43226 C...tanb (used for H+)
43230 C...Coupling to d-type quarks
43231 PARU(161)=SINA/COSB
43232 C...Coupling to u-type quarks
43233 PARU(162)=-COSA/SINB
43234 C...Coupling to leptons
43235 PARU(163)=PARU(161)
43239 PARU(165)=PARU(164)
43242 C...Coupling to d-type quarks
43243 PARU(171)=-COSA/COSB
43244 C...Coupling to u-type quarks
43245 PARU(172)=-SINA/SINB
43246 C...Coupling to leptons
43247 PARU(173)=PARU(171)
43251 PARU(175)=PARU(174)
43253 IF(IMSS(4).GE.2) THEN
43254 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
43256 HHH(3)=HHH(3)+HHH(4)+HHH(5)
43257 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
43258 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
43259 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
43260 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
43264 IF(IMSS(4).GE.2) THEN
43265 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
43267 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
43268 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
43269 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
43270 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
43273 IF(IMSS(4).GE.2) THEN
43274 PARU(177)=COS(2D0*BE)*COS(BE+AL)
43276 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
43277 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
43278 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
43279 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
43282 IF(IMSS(4).GE.2) THEN
43283 PARU(178)=PARU(177)
43285 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
43288 C...Coupling to d-type quarks
43290 C...Coupling to u-type quarks
43291 PARU(182)=1D0/PARU(181)
43292 C...Coupling to leptons
43293 PARU(183)=PARU(181)
43296 C...Coupling to Z h
43297 PARU(186)=COS(BE-AL)
43298 C...Coupling to Z H
43299 PARU(187)=SIN(BE-AL)
43305 C...Coupling to W h
43306 PARU(195)=COS(BE-AL)
43308 C...Tell that all Higgs couplings have been set.
43311 C...Set R-Violating couplings.
43312 C...Set lambda couplings to common value or "natural values".
43313 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
43314 VIR3=1D0/(126D0)**3
43318 IF (IRI.NE.IRJ) THEN
43319 IF (IRI.LT.IRJ) THEN
43320 RVLAM(IRI,IRJ,IRK)=RMSS(51)
43321 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
43322 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
43323 & PMAS(9+2*IRK,1)*VIR3)
43325 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
43328 RVLAM(IRI,IRJ,IRK)=0D0
43334 C...Set lambda' couplings to common value or "natural values".
43335 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
43336 VIR3=1D0/(126D0)**3
43340 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
43341 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
43342 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
43343 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
43348 C...Set lambda'' couplings to common value or "natural values".
43349 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
43350 VIR3=1D0/(126D0)**3
43354 IF (IRJ.NE.IRK) THEN
43355 IF (IRJ.LT.IRK) THEN
43356 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
43357 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
43358 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
43359 & PMAS(2*IRK-1,1)*VIR3)
43361 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
43364 RVLAMB(IRI,IRJ,IRK) = 0D0
43371 C...Antisymmetrize couplings set by user
43372 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
43376 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
43377 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
43378 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
43380 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
43381 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
43382 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
43389 C...Write spectrum to SLHA file
43390 IF (IMSS(23).NE.0) THEN
43392 CALL PYSLHA(3,0,IFAIL)
43395 C...Second part of routine: set decay modes and branching ratios.
43397 C...Allow chi10 -> gravitino + gamma or not.
43398 KC=PYCOMP(KSUSY1+39)
43399 IF( IMSS(11) .NE. 0 ) THEN
43400 PMAS(KC,1)=RMSS(21)/1D9
43403 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
43404 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
43406 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
43407 & ' ALLOWING SUSY LLE DECAYS'
43408 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
43409 & ' ALLOWING SUSY LQD DECAYS'
43410 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
43411 & ' ALLOWING SUSY UDD DECAYS'
43412 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
43413 & ' --- Warning: R-Violating couplings possibly',
43414 & ' incompatible with proton decay'
43420 C...Loop over sparticle and Higgs species.
43421 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
43422 C...Find the LSP or NLSP for a gravitino LSP
43427 IF(KF.EQ.1000039) GOTO 300
43429 IF(PMAS(KC,1).LT.PMLSP) THEN
43435 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
43437 IF (KF.EQ.0) GOTO 370
43441 C...Check if there are any decays listed for this sparticle
43443 IF (IMSS(22).NE.0) THEN
43445 C...First look for MASS entry if not already done
43446 IF (IMSS(1).NE.11.AND.IMSS(21).NE.0) CALL PYSLHA(5,KF,IFAIL)
43447 C...Then look for decay info
43449 CALL PYSLHA(2,KF,IFAIL)
43450 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
43451 ELSEIF (I.GE.37) THEN
43455 C...Sfermion decays.
43457 C...First check to see if sneutrino is lighter than chi10.
43458 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
43459 & PMAS(KC,1).LT.PMCHI1) THEN
43461 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
43465 ELSEIF(I.EQ.25) THEN
43466 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
43467 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
43469 C...Neutralino decays.
43470 ELSEIF(I.GE.26.AND.I.LE.29) THEN
43471 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
43472 C...chi10 stable or chi10 -> gravitino + gamma.
43473 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
43479 C...Chargino decays.
43480 ELSEIF(I.GE.30.AND.I.LE.31) THEN
43481 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
43483 C...Gravitino is stable.
43484 ELSEIF(I.EQ.32) THEN
43489 ELSEIF(I.GE.33.AND.I.LE.36) THEN
43490 C...Calculate decays to non-SUSY particles.
43491 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
43496 DO 330 I1=1,MDCY(KC,3)
43498 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
43499 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
43501 XLAM(0)=XLAM(0)+XLAM(I1)
43503 IDLAM(I1,J1)=KFDP(K1,J1)
43507 C...Add the decays to SUSY particles.
43508 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
43510 C...Zero the branching ratios for use in loop mode
43511 C...thanks to K. Matchev (FNAL)
43512 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
43516 C...Set stable particles.
43524 C...Store branching ratios in the standard tables.
43526 IDC=MDCY(KC,2)+MDCY(KC,3)-1
43532 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
43533 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
43534 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
43535 BRAT(IDC)=XLAM(IL)/XLAM(0)
43537 IF(MDME(IDC,1).GE.1) THEN
43538 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
43539 & PMAS(PYCOMP(KFDP(IDC,2)),1)
43540 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
43541 & PMAS(PYCOMP(KFDP(IDC,3)),1)
43544 IF(XMDIF.GE.0D0) THEN
43545 DELM=MIN(DELM,XMDIF)
43547 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
43548 WRITE(MSTU(11),*) ' KF = ',KF
43549 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
43553 ELSEIF(IDC.EQ.IDCSV) THEN
43554 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
43555 & 'channel not recognized:'
43556 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
43563 C...Store width, cutoff and lifetime.
43565 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
43566 PMAS(KC,3)=PMAS(KC,2)*10D0
43568 PMAS(KC,3)=0.95D0*DELM
43570 IF(PMAS(KC,2).NE.0D0) THEN
43571 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
43573 C...Write decays to SLHA file
43574 IF (IMSS(24).NE.0) THEN
43576 CALL PYSLHA(4,KF,IFAIL)
43584 C*********************************************************************
43587 C...Read/write spectrum or decay data from SLHA standard file(s).
43590 C...MUPDA=1 : READ SPECTRUM ON LUN=IMSS(21)
43591 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
43592 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
43593 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
43594 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY (WITH DECAY TABLE)
43595 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
43597 C...Double precision and integer declarations.
43598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43599 IMPLICIT INTEGER(I-N)
43600 INTEGER PYK,PYCHGE,PYCOMP
43601 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43602 &KEXCIT=4000000,KDIMEN=5000000)
43604 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43605 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43606 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43607 COMMON/PYDAT4/CHAF(500,2)
43609 CHARACTER*40 ISAVER,VISAJE
43610 COMMON/PYINT4/MWID(500),WIDS(500,5)
43611 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
43613 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43614 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43615 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43616 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43617 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
43619 C...Local arrays, character variables and data.
43620 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
43621 & AU(3,3),AD(3,3),AE(3,3)
43622 COMMON/PYLH3C/CPRO(2),CVER(2)
43623 SAVE /PYLH3P/,/PYLH3C/
43624 DIMENSION MMOD(100),MSPC(100),MDEC(100)
43625 C...MMOD: flags to set for each block read in.
43626 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
43627 C...MSPC: Flags to set for each block read in.
43628 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
43629 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
43630 C...11: AD 12: AE 13: YU 14: YD 15: YE
43631 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
43632 CHARACTER CPRO*12,CVER*12,CHNLIN*6
43633 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
43634 CHARACTER CHINL*120,CHKF*9,CHTMP*16
43637 C...Date of last Change
43638 PARAMETER (DOC='05 Mar 2007')
43639 C...MQREAD(0): Number of entries I in MQREAD
43640 C... (I): KF code for which a QNUMBERS block has been read.
43641 DIMENSION IDC(5),KFSUSY(50),MQREAD(0:100)
43646 &1000001,1000002,1000003,1000004,1000005,1000006,
43647 &2000001,2000002,2000003,2000004,2000005,2000006,
43648 &1000011,1000012,1000013,1000014,1000015,1000016,
43649 &2000011,2000012,2000013,2000014,2000015,2000016,
43650 &1000021,1000022,1000023,1000025,1000035,1000024,
43651 &1000037,1000039, 25, 35, 36, 37,
43652 & 6, 24, 45, 46,1000045, 9*0/
43653 RMFUN(IP)=PMAS(PYCOMP(IP),1)
43656 IF (NHELLO.EQ.0) THEN
43657 WRITE(MSTU(11),5000) DOC
43661 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
43664 IF (MUPDA.EQ.5) LFN=IMSS(21)
43665 IF (MUPDA.EQ.0) LFN=IMSS(21)
43666 C...Flag that we have not yet found whatever we were asked to find.
43669 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
43671 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
43675 C...If told to read spectrum, first zero all previous information.
43676 IF (MUPDA.EQ.1) THEN
43677 C...Zero all block read flags
43683 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
43685 KC=PYCOMP(KFSUSY(ISUSY))
43691 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
43699 IF (J.LE.2.AND.L.LE.2) THEN
43706 C...Zero signed masses.
43708 IF (J.LE.2) SMW(J)=0D0
43710 C...NB: RMSS array not zeroed.
43712 & '* (PYSLHA:) Reading in SLHA spectrum from unit ', LFN
43714 C...If reading decays, reset PYTHIA decay counters.
43715 ELSEIF (MUPDA.EQ.2) THEN
43719 DO 140 KC=1,MSTU(6)
43720 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
43721 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
43723 ELSEIF (MUPDA.EQ.5) THEN
43724 C...Zero block read flags
43731 C...(spectrum or look for decays of KF=KFORIG or MASS of KF=KFORIG
43732 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
43733 C...Initialize program and version strings
43737 C...Initialize read loop
43741 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
43743 READ(LFN,'(A120)',END=300) CHINL
43744 C...Count which line number we're at.
43746 WRITE(CHNLIN,'(I6)') NLINE
43748 C...Skip comment and empty lines without processing.
43749 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 160
43751 C...We assume all upper case below. Rewrite CHINL to all upper case.
43755 IF (CHINL(INL:INL).NE.'#') THEN
43757 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
43759 C...Extra safety. Chek for sensible input on line
43760 IF (IGOOD.EQ.0) THEN
43762 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
43765 IF (INL.LT.120) GOTO 170
43767 IF (IGOOD.EQ.0) GOTO 160
43769 C...Check for BLOCK begin statement (spectrum).
43770 IF (CHINL(1:1).EQ.'B') THEN
43772 READ(CHINL,'(A6,A)',ERR=460) CHDUM,CHBLCK
43773 C...Check if another of this type of block was already read.
43774 C...(logarithmic interpolation not yet implemented, so duplicates always
43776 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
43777 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
43778 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
43779 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
43780 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
43781 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
43782 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
43783 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
43784 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
43785 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
43786 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
43787 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
43788 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
43789 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
43790 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
43791 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
43792 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
43793 C...Check for new particles
43794 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
43796 MSPC(19)=MSPC(19)+1
43798 READ(CHBLCK(9:60),*) KFQ
43800 DO 121 MQ=1,MQREAD(0)
43801 IF (MQREAD(MQ).EQ.KFQ) THEN
43806 WRITE(MSTU(11),'(A,I9,A,F12.3)')
43807 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
43809 MQREAD(0)=MQREAD(0)+1
43810 MQREAD(MQREAD(0))=KFQ
43811 MSPC(19)=MSPC(19)+1
43814 DO 123 KCT=100,MSTU(6)
43815 IF(KCHG(KCT,4).GT.100) KCQ=KCT
43820 C...First write PDG code as name
43822 C...Then look for real name
43825 IF (CHBLCK(ICMT:ICMT).NE.'#'.AND.ICMT.LT.59) GOTO 90
43826 IF (ICMT.LT.59) THEN
43827 READ(CHBLCK(ICMT+1:60),'(A)',ERR=95) CHDUM
43828 IF (CHDUM.NE.' ') CHTMP=CHDUM
43830 95 IF (CHTMP(1:1).EQ.' ') THEN
43831 READ(CHTMP,'(1x,A)') CHAF(KCQ,1)
43833 READ(CHTMP,'(A)') CHAF(KCQ,1)
43836 C...Set stable for now
43844 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
43845 & CHAF(KCQ,1), '. Entry ignored.'
43849 C...Finalize this line and read next.
43851 C...Check for DECAY begin statement (decays).
43852 ELSEIF (CHINL(1:1).EQ.'D') THEN
43856 C...Read KF code and WIDTH
43858 READ(CHINL(7:INL),*,ERR=470) KF, WIDTH
43863 C...If this is not the KF we're looking for...
43864 IF (KF.NE.KFORIG.OR.MUPDA.NE.2) THEN
43865 C...Set block skip flag and read next line.
43870 C...Determine PYTHIA KC code of particle
43876 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
43880 IF (KCREP.NE.0) THEN
43881 C...Particle is already known. Don't do anything yet.
43883 C... Add new particle. Actually, this should not happen.
43884 C... New particles should be added already when reading the spectrum
43885 C... information, so go under previously stable category.
43890 IF (WIDTH.LE.0D0) THEN
43891 C...Stable (i.e. LSP)
43893 & '* (PYSLHA:) Reading in SLHA stable particle: ',
43895 IF (WIDTH.LT.0D0) THEN
43896 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
43903 C...Ignore any decay lines that may be present for this KF
43910 C...Finalize and start reading in decay modes.
43912 ELSEIF (MOD(MERR,10).GE.6) THEN
43913 C...If ignore block flag set, skip directly to next line.
43918 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
43919 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
43921 READ(CHINL,*) INDX, IVAL
43922 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
43923 IF (INDX.EQ.3) KCHG(KCQ,2)=0
43924 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
43925 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
43926 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
43927 IF (INDX.EQ.4) THEN
43929 IF (IVAL.EQ.1) THEN
43931 IF (CHTMP.EQ.' ') THEN
43932 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
43933 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
43937 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 116
43938 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
43939 CHTMP(ILAST:ILAST)='-'
43941 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
43950 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
43951 C...MASS: Mass spectrum
43952 IF (CHBLCK(1:4).EQ.'MASS') THEN
43953 READ(CHINL,*) KF, VAL
43956 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG) THEN
43957 C...Read in masses for anything
43962 PMAS(KC,1) = ABS(VAL)
43963 IF (MUPDA.EQ.5) THEN
43964 WRITE(MSTU(11),'(A,I9,A,F12.3)')
43965 & ' * (PYSLHA:) Reading in MASS entry for KF =',
43966 & KF, ', pole mass =', VAL
43970 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
43971 IF (KF.EQ.1000022) SMZ(1)=VAL
43972 IF (KF.EQ.1000023) SMZ(2)=VAL
43973 IF (KF.EQ.1000025) SMZ(3)=VAL
43974 IF (KF.EQ.1000035) SMZ(4)=VAL
43975 IF (KF.EQ.1000024) SMW(1)=VAL
43976 IF (KF.EQ.1000037) SMW(2)=VAL
43978 ELSEIF (MUPDA.EQ.5) THEN
43981 ELSEIF (MUPDA.EQ.5) THEN
43982 C...Only read MASS if MUPDA = 5. Skip any other blocks.
43984 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
43985 & CHBLCK(1:8).EQ.'PARTICLE') THEN
43986 C...Don't print a warning for QNUMBERS when reading spectrum
43988 C... MODSEL: Model selection and global switches
43989 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
43990 READ(CHINL,*) INDX, IVAL
43991 IF (INDX.LE.200.AND.INDX.GT.0) THEN
43994 IF (INDX.EQ.3.AND.IVAL.EQ.1) THEN
43995 C... Switch on NMSSM
43996 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
43997 IMSS(13)=MAX(1,IMSS(13))
43998 C... Add NMSSM states if not already done
44028 DO 234 KCT=100,MSTU(6)
44029 IF(KCHG(KCT,4).GT.100) KCN=KCT
44035 C... Set stable for now
44041 CHAF(KCN,1)='~chi_50'
44047 C...MINPAR: Minimal model parameters
44048 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
44049 IF (MODSEL(1).NE.0) THEN
44050 READ(CHINL,*) INDX, VAL
44051 IF (INDX.LE.100.AND.INDX.GT.0) THEN
44057 ELSEIF (MMOD(3).NE.0) THEN
44059 & '* (PYSLHA:) MINPAR after EXTPAR !'
44063 & '* (PYSLHA:) Reading MINPAR, but no MODSEL !'
44067 IF (INDX.EQ.3) RMSS(5)=VAL
44068 C...EXTPAR: non-minimal model parameters.
44069 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
44070 IF (MMOD(1).NE.0) THEN
44071 READ(CHINL,*) INDX, VAL
44072 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44080 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
44084 IF (INDX.EQ.25) RMSS(5)=VAL
44085 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
44086 READ(CHINL,*) INDX, VAL
44087 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
44089 ELSEIF (INDX.EQ.4) THEN
44090 PMAS(PYCOMP(23),1)=VAL
44091 ELSEIF (INDX.EQ.6) THEN
44092 PMAS(PYCOMP(6),1)=VAL
44094 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
44095 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
44096 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
44098 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
44100 IF (CHBLCK(5:6).EQ.'IM') IM=1
44101 250 READ(CHINL,*) INDX1, INDX2, VAL
44102 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
44103 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
44104 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
44106 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
44107 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
44108 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
44110 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
44111 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
44112 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
44114 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
44115 $ .CHBLCK(1:4).EQ.'STAU') THEN
44116 IF (CHBLCK(1:4).EQ.'STOP') THEN
44119 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
44122 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
44126 C...Set SFMIX element
44127 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
44128 MSPC(ISPC)=MSPC(ISPC)+1
44130 C...Running parameters
44131 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
44132 READ(CHBLCK(8:25),*,ERR=510) Q
44133 READ(CHINL,*) INDX, VAL
44135 IF (INDX.EQ.1) THEN
44141 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
44142 READ(CHINL,*,ERR=520) VAL
44144 MSPC(17)=MSPC(17)+1
44145 C...Higgs parameters set manually or with FeynHiggs.
44146 IMSS(4)=MAX(2,IMSS(4))
44147 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
44148 & .CHBLCK(1:2).EQ.'AE') THEN
44149 READ(CHBLCK(9:26),*,ERR=510) Q
44150 READ(CHINL,*) INDX1, INDX2, VAL
44151 IF (CHBLCK(2:2).EQ.'U') THEN
44152 AU(INDX1,INDX2)=VAL
44153 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
44154 MSPC(11)=MSPC(11)+1
44155 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
44156 AD(INDX1,INDX2)=VAL
44157 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
44158 MSPC(10)=MSPC(10)+1
44159 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
44160 AE(INDX1,INDX2)=VAL
44161 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
44162 MSPC(12)=MSPC(12)+1
44166 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
44167 IF (MSPC(18).EQ.0) THEN
44168 READ(CHBLCK(9:25),*,ERR=510) Q
44171 READ(CHINL,*) INDX, VAL
44173 MSPC(18)=MSPC(18)+1
44174 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
44176 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
44177 & .CHBLCK(1:2).EQ.'YE') THEN
44179 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
44180 READ(CHINL(1:6),*) INDX
44184 IF (CHINL(IT:IT).EQ.' ') GOTO 260
44185 C...Don't read index
44186 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
44190 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
44191 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
44193 C... Set unrecognized block flag.
44198 C...Read in decay information
44199 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
44200 C...Read new decay chanel
44201 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
44203 C...Read in branching ratio and number of daughters for this mode.
44204 READ(CHINL(4:50),*,ERR=480) BRAT(NDC)
44205 READ(CHINL(4:50),*,ERR=490) DUM, NDA
44207 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
44208 & '(PYSLHA:) Decay data arrays full by KF ='
44210 C...If first decay chanel, set decays start point in decay table
44211 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
44213 & '* (PYSLHA:) Reading in SLHA decay table for ',
44215 C...Set particle parameters (mass set when reading BLOCK MASS above)
44217 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
44219 & '* Note: the Pythia gg->h/H/A cross section'//
44220 & ' is proportional to the h/H/A->gg width'
44223 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
44231 C... Count up number of decay modes for this particle
44232 MDCY(KC,3)=MDCY(KC,3)+1
44233 C... Read in decay daughters.
44234 READ(CHINL(4:120),*,ERR=500) DUM,IDM, (IDC(IDA),IDA=1,NDA)
44235 C... Flip sign if reading antiparticle decays (if antipartner exists)
44237 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
44238 & IDC(IDA)=MPSIGN*IDC(IDA)
44240 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
44242 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
44243 BRSUM=BRSUM+ABS(BRAT(NDC))
44244 BRAT(NDC)=ABS(BRAT(NDC))
44247 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
44249 IDC(IDA)=IDC(IDA+1)
44254 IF (IFLIP.GT.0) GOTO 274
44255 C WRITE(MSTU(11),7510) BRAT(NDC), NDA, (IDC(IDA),IDA=1,NDA)
44256 C...Treat as ordinary decay, no fancy stuff.
44259 IF (IDA.LE.NDA) THEN
44260 KFDP(NDC,IDA)=IDC(IDA)
44266 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
44271 ELSEIF(CHINL(1:1).EQ.'+') THEN
44273 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
44280 290 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
44281 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
44284 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
44285 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
44286 & CHBLCK(1:INL)//'... on line'//CHNLIN
44287 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
44288 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
44289 & //CHBLCK(1:INL)//'... on line'//CHNLIN
44290 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS(21).EQ.0.AND.
44291 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
44292 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
44293 & //'... on line'//CHNLIN
44294 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
44295 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
44296 & /CHBLCK(1:INL)//'... on line'//CHNLIN
44297 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
44300 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
44301 & CHTMP(1:9)//' on line'//CHNLIN
44306 C...Set flag that KC codes have been rearranged.
44310 C...Perform possible tests that new information is consistent.
44311 IF (MUPDA.EQ.1) THEN
44314 C...Check Z and top masses
44315 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
44316 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
44317 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
44319 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
44320 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
44321 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
44327 C...Don't complain about right-handed neutrinos
44328 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
44330 C...Only check gravitino in GMSB scenarios
44331 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 310
44333 IF (PMAS(KC,1).EQ.0D0) THEN
44336 & ,'(PYSLHA:) No mass information found for KF = '
44340 C...Check mixing matrices (MSSM only)
44341 IF (IMSS(13).EQ.0) THEN
44342 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
44343 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
44344 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
44345 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
44346 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
44347 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
44348 IF (MSPC(5).NE.4) CALL PYERRM(9
44349 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
44350 IF (MSPC(6).NE.4) CALL PYERRM(9
44351 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
44352 IF (MSPC(7).NE.4) CALL PYERRM(9
44353 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
44354 IF (MSPC(8).LT.1) CALL PYERRM(9
44355 & ,'(PYSLHA:) Too few elements in HMIX')
44356 IF (MSPC(10).EQ.0) CALL PYERRM(9
44357 & ,'(PYSLHA:) Missing A_b trilinear coupling')
44358 IF (MSPC(11).EQ.0) CALL PYERRM(9
44359 & ,'(PYSLHA:) Missing A_t trilinear coupling')
44360 IF (MSPC(12).EQ.0) CALL PYERRM(9
44361 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
44362 IF (MSPC(17).LT.1) CALL PYERRM(9
44363 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
44365 C...Check wavefunction normalizations.
44368 IF (MSPC(ISPC).EQ.4) THEN
44370 IF (ISPC.EQ.7) KFSM=15
44371 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
44373 IF (ABS(1D0-CHECK).GT.1D-3) THEN
44376 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
44381 C...Neutralinos + charginos
44390 CN1=CN1+ZMIX(J,L)**2
44391 CN2=CN2+ZMIX(L,J)**2
44392 IF (J.LE.2.AND.L.LE.2) THEN
44393 CU1=CU1+UMIX(J,L)**2
44394 CU2=CU2+UMIX(L,J)**2
44395 CV1=CV1+VMIX(J,L)**2
44396 CV2=CV2+VMIX(L,J)**2
44399 C...NMIX normalization
44400 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
44401 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
44403 & '(PYSLHA:) NMIX: Inconsistent normalization.')
44404 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
44406 C...UMIX, VMIX normalizations
44407 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
44409 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
44411 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
44412 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
44415 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
44417 & '(PYSLHA:) VMIX: Inconsistent normalization.')
44418 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
44424 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
44425 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
44426 & '* PYSLHA: No spectrum inconsistencies were found.'
44428 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
44429 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
44430 & ,'Warning: one or more (serious)'//
44431 & ' inconsistencies were found in the spectrum!!!'
44432 & ,'Read the error messages above and check your'//
44435 C...Increase precision in Higgs sector using FeynHiggs
44436 IF (IMSS(4).EQ.3) THEN
44437 C...FeynHiggs needs MSOFT.
44439 IF (MSPC(18).EQ.0) THEN
44440 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
44441 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
44442 & ' Cannot call FeynHiggs.'
44445 WRITE(MSTU(11),'(1x,/1x,A/)')
44446 & '* (PYSLHA:) Now calling FeynHiggs.'
44448 IF (IERR.NE.0) IMSS(4)=2
44451 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0) THEN
44454 WRITE(CHKF,8300) KF
44455 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
44456 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
44457 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
44458 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
44462 DO 360 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44463 IF(MDME(IDA,2).GT.80) GOTO 360
44465 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
44469 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
44471 ELSEIF(PYCOMP(KP).EQ.0) THEN
44476 PMS=PMS-PMAS(KPC,1)
44477 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
44481 IF(KQ.NE.0) MERR=MAX(2,MERR)
44482 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
44484 IF(MERR.EQ.3) CALL PYERRM(17,
44485 & '(PYSLHA:) Unknown particle code in decay of KF ='
44487 IF(MERR.EQ.2) CALL PYERRM(17,
44488 & '(PYSLHA:) Charge not conserved in decay of KF ='
44490 IF(MERR.EQ.1) CALL PYERRM(7,
44491 & '(PYSLHA:) Kinematically unallowed decay of KF ='
44493 BRSUM=BRSUM+BRAT(IDA)
44494 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
44496 C...Check branching ratio sum.
44497 IF (BROPN.LE.0D0) THEN
44498 C...If zero, set stable.
44499 WRITE(CHTMP,8500) BROPN
44501 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
44502 & CHTMP(9:16)//'. Changed to stable.')
44505 C...If BR's > 1, rescale.
44506 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
44507 WRITE(CHTMP,8500) BRSUM
44509 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
44510 & ' ; sum was'//CHTMP(9:16)//'.')
44512 DO 370 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44513 IF(MDME(IDA,2).GT.80) GOTO 370
44514 BRAT(IDA)=FAC*BRAT(IDA)
44516 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
44517 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
44518 WRITE(CHTMP,8500) BRSUM
44520 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
44521 & CHTMP(9:16)//'. Dummy mode will be inserted.')
44522 C... Insert dummy mode
44523 MDCY(KC,3)=MDCY(KC,3)+1
44524 IDA=MDCY(KC,2)+MDCY(KC,3)-1
44525 BRAT(IDA)=1D0-BRSUM
44536 C...WRITE SPECTRUM ON SLHA FILE
44537 ELSEIF(MUPDA.EQ.3) THEN
44538 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
44539 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
44544 PARMIN(4)=SIGN(1D0,RMSS(4))
44548 WRITE(LFN,7000) 'SLHA MSSM spectrum'
44549 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
44551 WRITE(LFN,7010) 'MODSEL', 'Model selection'
44552 WRITE(LFN,7110) 1, MODSEL(1)
44553 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
44554 IF (MODSEL(1).EQ.1) THEN
44555 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
44556 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
44557 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
44558 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
44559 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
44560 ELSEIF(MODSEL(2).EQ.2) THEN
44561 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
44562 WRITE(LFN,7210) 2, PARMIN(2), 'M'
44563 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
44564 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
44565 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
44566 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
44568 WRITE(LFN,7000) ' '
44569 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
44573 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 380
44575 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
44576 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
44577 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
44578 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
44579 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
44580 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
44581 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
44583 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
44587 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
44588 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
44589 WRITE(LFN,7210) 1, RMSS(4),'mu'
44590 WRITE(LFN,7010) 'ALPHA',' '
44591 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
44592 WRITE(LFN,7020) 'AU',RMSUSY
44593 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
44594 WRITE(LFN,7020) 'AD',RMSUSY
44595 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
44596 WRITE(LFN,7020) 'AE',RMSUSY
44597 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
44598 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
44599 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
44600 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
44601 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
44602 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
44603 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
44604 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
44605 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
44606 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
44607 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
44608 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
44609 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
44610 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
44611 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
44612 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
44613 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
44616 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
44619 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
44622 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
44625 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
44628 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
44631 WRITE(LFN,7010) 'SPINFO'
44632 IF (IMSS(1).EQ.2) THEN
44635 ELSEIF (IMSS(1).EQ.12) THEN
44638 CVER(1)=ISAVER(1:12)
44640 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
44641 WRITE(LFN,7310) 2, CVER(1), 'Version number'
44644 C...Print user information about spectrum
44645 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
44646 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
44647 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
44648 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
44649 IF (MUPDA.EQ.1) THEN
44650 WRITE(MSTU(11),5020) LFN
44652 WRITE(MSTU(11),5010) LFN
44655 WRITE(MSTU(11),5400)
44656 WRITE(MSTU(11),5500) 'Pole masses'
44657 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
44658 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
44659 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
44660 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
44661 IF (IMSS(13).EQ.0) THEN
44662 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
44663 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
44664 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
44665 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
44666 & CHAF(37,1), ' ', ' ',' ',' ',
44667 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
44668 ELSEIF (IMSS(13).EQ.1) THEN
44677 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
44678 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
44679 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
44680 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
44681 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
44682 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
44683 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
44684 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
44685 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
44688 WRITE(MSTU(11),5400)
44689 WRITE(MSTU(11),5500) 'Mixing structure'
44690 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
44691 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
44692 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
44693 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
44694 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
44695 & ),(SFMIX(15,J),J=3,4)
44696 WRITE(MSTU(11),5400)
44697 WRITE(MSTU(11),5500) 'Couplings'
44698 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
44699 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
44700 WRITE(MSTU(11),5400)
44701 WRITE(MSTU(11),6500)
44705 C...Only rewind when reading
44706 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
44710 C...Serious error catching
44711 460 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
44712 write(*,*) CHINL(1:80)
44714 470 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
44715 WRITE(*,*) CHINL(1:72)
44717 480 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE
44718 WRITE(*,*) CHINL(1:80)
44720 490 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
44721 WRITE(*,*) CHINL(1:80)
44723 500 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
44724 WRITE(*,*) CHINL(1:80)
44725 510 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
44727 520 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
44728 WRITE(*,*) CHINL(1:80)
44734 C...Formats for user information printout.
44735 5000 FORMAT(1x,15('*'),1x,'PYSLHA v1.09: SUSY/BSM SPECTRUM '
44736 & ,'INTERFACE',1x,15('*')/1x,'*',2x
44737 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
44738 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
44739 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
44740 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
44741 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
44742 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
44743 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
44744 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
44745 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
44746 & ,'----------------')
44747 5400 FORMAT(1x,'*',1x,A)
44748 5500 FORMAT(1x,'*',1x,A,':')
44749 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
44750 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
44751 5700 FORMAT(1x,'*',4x,4x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
44752 & 4x,'~c',2x,1x,1x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
44753 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
44754 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,2x,'~nu_e',2x,1x,3x,'~mu',2x
44755 & ,1x,1x,'~nu_mu',1x,1x,'~tau(12)',1x,1x,'~nu_tau'/1x,'*',2x
44756 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
44757 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
44758 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
44759 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
44760 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
44761 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
44762 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
44763 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
44764 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
44765 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
44766 & ,1x,F6.3,1x),'|')
44767 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
44768 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
44769 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
44770 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
44771 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
44772 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
44773 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
44774 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
44775 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
44776 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
44777 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
44778 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
44779 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
44780 & ,'A_tau = ',F8.2)
44781 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
44783 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
44785 C...Format to use for comments
44786 7000 FORMAT('# ',A)
44787 C...Format to use for block statements
44788 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
44789 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
44791 7110 FORMAT(1x,I4,1x,I4,3x,'#')
44792 C...Non-Indexed Double
44793 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
44795 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
44796 C...Long Indexed Double (PDG + double)
44797 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
44798 C...Indexed Char(12)
44799 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
44801 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
44803 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
44804 C...Write Decay Table
44805 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
44806 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
44811 C*********************************************************************
44814 C...Uses approximate analytical formulae to determine the full set of
44815 C...MSSM parameters from SUGRA input.
44816 C...See M. Drees and S.P. Martin, hep-ph/9504124
44820 C...Double precision and integer declarations.
44821 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44822 IMPLICIT INTEGER(I-N)
44823 INTEGER PYK,PYCHGE,PYCOMP
44824 C...Parameter statement to help give large particle numbers.
44825 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44826 &KEXCIT=4000000,KDIMEN=5000000)
44828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44829 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44830 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44831 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
44833 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
44834 &' not intended for serious physics studies'
44847 C...Temporary sign change for AT. Others unchanged.
44851 SINB=TANB/SQRT(TANB**2+1D0)
44854 DTERM=XMZ2*COS(2D0*BETA)
44855 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
44856 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
44859 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
44860 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
44861 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
44862 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
44864 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
44865 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
44866 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
44867 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
44869 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
44870 IF(XARG.LT.0D0) THEN
44871 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44872 & ' FROM THE SUM RULE. '
44873 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44879 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
44880 PMAS(PYCOMP(KSUSY2+I),1)=XMER
44881 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44882 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44884 RMT=PYMRUN(6,PMAS(6,1)**2)
44885 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
44886 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
44887 RMB=PYMRUN(5,PMAS(6,1)**2)
44888 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
44889 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
44890 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
44891 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
44894 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
44895 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
44896 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
44897 XMU=SIGN(SQRT(XMU2),RMSS(4))
44899 IF(XMA2.GT.0D0) THEN
44900 RMSS(19)=SQRT(XMA2)
44902 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
44905 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
44906 IF(ARG.GT.0D0) THEN
44909 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
44912 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
44913 IF(ARG.GT.0D0) THEN
44916 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
44919 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
44920 IF(ARG.GT.0D0) THEN
44923 RMSS(10)=-SQRT(-ARG)
44925 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
44926 IF(ARG.GT.0D0) THEN
44929 RMSS(12)=-SQRT(-ARG)
44931 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
44932 IF(ARG.GT.0D0) THEN
44935 RMSS(11)=-SQRT(-ARG)
44941 C*********************************************************************
44944 C...Interface to ISASUSY version 7.71.
44945 C...Warning: this interface should not be used with earlier versions
44946 C...of ISASUSY, since common block incompatibilities may then arise.
44947 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
44948 C...Then converts to Gunion-Haber conventions.
44951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44953 INTEGER PYK,PYCHGE,PYCOMP
44954 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44955 &KEXCIT=4000000,KDIMEN=5000000)
44959 PARAMETER (DOC='01 May 2006')
44961 C...ISASUGRA Input:
44962 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
44963 C...XISAIN contains the MSSMi inputs in natural order.
44964 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
44966 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
44968 C...ISASUGRA Output
44969 CHARACTER*40 ISAVER,VISAJE
44971 COMMON /SSPAR/ SUPER(72)
44972 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
44973 $FBGUT,FTAGUT,FNGUT
44974 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
44975 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
44976 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
44977 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
44978 $VUMT,VDMT,ASMTP,ASMSS,M3Q
44979 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
44980 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
44981 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
44982 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
44984 SAVE /SUGMG/,/SSPAR/
44985 C SUPER: Filled by ISASUGRA.
44986 C SUPER(1) = mass of ~g
44987 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
44988 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
44989 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
44991 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
44992 C SUPER(29) = Higgsino mass = - mu
44993 C SUPER(30) = ratio v2/v1 of vev's
44994 C SUPER(31:34) = Signed neutralino masses
44995 C SUPER(35:50) = Neutralino mixing matrix
44996 C SUPER(51:52) = Signed chargino masses
44997 C SUPER(53:54) = Chargino left, right mixing angles
44998 C SUPER(55:58) = mass of h0, H0, A0, H+
44999 C SUPER(59) = Higgs mixing angle alpha
45000 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
45001 C SUPER(66) = Gravitino mass
45002 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
45003 C SUPER(70) = b-Yukawa at mA scale (not used)
45004 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
45005 C GSS: Filled by ISASUGRA
45006 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
45007 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
45008 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
45009 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
45010 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
45011 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
45012 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
45013 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
45014 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
45015 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
45016 C GSS(31) = log(vuq)
45017 C MSS: Filled by ISASUGRA
45018 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
45019 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
45020 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
45021 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
45022 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
45023 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
45024 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
45025 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
45026 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
45027 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
45028 C MSS(31) = ha0 MSS(32) = h+
45029 C Unification, filled by ISASUGRA if applicable.
45030 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
45032 C...SPYTHIA Input/Output
45034 DOUBLE PRECISION RMSS
45035 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45036 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45037 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45038 C...SLHA Input/Output
45039 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45040 & AU(3,3),AD(3,3),AE(3,3)
45041 C...PYTHIA common blocks
45042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45043 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45044 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45046 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
45047 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
45050 CHARACTER*20 CHMOD(5)
45053 COMMON /SUGNU/ XNUSUG(18)
45057 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
45058 & 'truly unified SUGRA', 'non-minimal GMSB'/
45060 C...Start by checking for incompatibilities/inconsistencies:
45062 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
45063 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
45064 & ,' option not used by PYSUGI'
45067 C...ISAJET works with REAL numbers.
45068 MZERO=REAL(RMSS(8))
45070 AZERO=REAL(RMSS(16))
45072 SGNMU=REAL(RMSS(4))
45073 MTOP=REAL(PMAS(6,1))
45075 IF (IMSS(1).EQ.12) THEN
45078 ELSEIF(IMSS(1).EQ.13) THEN
45079 C...Read from isajet par file in IMSS(20)
45081 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45083 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
45086 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
45087 CMrenna change to allow any susy model
45088 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
45089 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
45090 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
45091 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
45092 & ' gauge couplings:'
45093 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
45095 IF (IMODEL.EQ.4) THEN
45099 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
45100 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
45101 & //' sgn(mu), M_t:'
45102 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
45103 IF (IMODEL.EQ.3) THEN
45105 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
45106 & //' 0 to continue:'
45107 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
45108 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
45109 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
45110 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
45111 & //' generation masses'
45113 & ' NUSUG5 = GUT scale 3rd generation masses'
45115 IF (INUSUG.EQ.0) THEN
45117 ELSEIF (INUSUG.EQ.1) THEN
45118 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
45119 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
45120 IF (XNUSUG(3).LE.0.) THEN
45121 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
45124 ELSEIF (INUSUG.EQ.2) THEN
45125 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
45126 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
45127 ELSEIF (INUSUG.EQ.3) THEN
45128 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
45129 READ(LFN,*) XNUSUG(7),XNUSUG(8)
45130 ELSEIF (INUSUG.EQ.4) THEN
45131 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
45132 & //' M(ur), M(el), M(er):'
45133 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
45134 & XNUSUG(10),XNUSUG(9)
45135 ELSEIF (INUSUG.EQ.5) THEN
45136 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
45137 & //' M(Ll), M(Lr):'
45138 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
45139 & XNUSUG(15),XNUSUG(14)
45143 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
45145 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
45146 & ,' sgn(mu), M_t, C_gv:'
45147 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
45150 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
45152 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
45153 IF (IMODEL.EQ.5) THEN
45155 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
45156 & ,' masses at M_mes'
45157 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
45158 & ,' shifts at M_mes'
45159 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
45161 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
45163 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
45165 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
45166 $ XGMIN(13),XGMIN(14)
45169 WRITE(MSTU(11),*) 'Invalid model choice.'
45177 C TANB=REAL(RMSS(5))
45178 C SGNMU=REAL(RMSS(4))
45181 C...Initialize MSSM parameter array
45182 130 DO 140 IPAR=1,72
45186 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
45187 C...Check whether ISASUSY thought the model was OK.
45188 IF (NOGOOD.NE.0) THEN
45189 IF (NOGOOD.EQ.1) CALL PYERRM(26
45190 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
45191 IF (NOGOOD.EQ.2) CALL PYERRM(26
45192 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
45193 IF (NOGOOD.EQ.3) CALL PYERRM(26
45194 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
45195 IF (NOGOOD.EQ.4) CALL PYERRM(26
45196 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
45197 IF (NOGOOD.EQ.7) CALL PYERRM(26
45198 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
45199 IF (NOGOOD.EQ.8) CALL PYERRM(26
45200 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
45201 C...Give warning, but don't stop, if LSP not ~chi_10.
45202 IF (NOGOOD.EQ.5) CALL PYERRM(16
45203 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
45205 C...Warn about possible GUT scale tachyons.
45206 IF (ITACHY.NE.0) CALL PYERRM(16,
45207 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
45208 C...Finalize spectrum (last iteration)
45209 C...(Thanks to A. Raklev for pointing this out.)
45210 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
45211 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
45212 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
45213 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
45214 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
45215 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
45219 RMSS(1)=dble(GSS(7))
45220 RMSS(2)=dble(GSS(8))
45221 RMSS(3)=dble(GSS(9))
45222 RMSOFT(1)=dble(GSS(7))
45223 RMSOFT(2)=dble(GSS(8))
45224 RMSOFT(3)=dble(GSS(9))
45225 C...Mu = - Higgsino mass.
45228 C...Slepton and squark masses. 2 first generations.
45229 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
45230 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
45231 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
45232 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
45233 C...Third generation.
45234 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
45239 C...SLHA: store exact soft spectrum in RMSOFT
45240 RMSOFT(31)=SUPER(18)
45241 RMSOFT(32)=SUPER(20)
45242 RMSOFT(33)=SUPER(22)
45243 RMSOFT(34)=SUPER(19)
45244 RMSOFT(35)=SUPER(21)
45245 RMSOFT(36)=SUPER(23)
45246 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
45247 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
45248 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
45249 RMSOFT(44)=SUPER(3)
45250 RMSOFT(45)=SUPER(9)
45251 RMSOFT(46)=SUPER(15)
45252 RMSOFT(47)=SUPER(5)
45253 RMSOFT(48)=SUPER(7)
45254 RMSOFT(49)=SUPER(11)
45256 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
45263 C...SLHA trilinears
45274 C...Higgs mixing angle alpha (Gunion-Haber convention).
45275 RMSS(18)=-SUPER(59)
45278 C...GUT scale coupling
45280 C...Gravitino mass (for future compatibility)
45281 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
45283 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
45285 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
45286 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
45287 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
45288 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
45290 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
45291 C...Squarks and Sleptons.
45294 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
45295 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
45296 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
45297 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
45298 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
45299 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
45300 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
45301 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
45302 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
45304 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
45305 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
45306 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
45308 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
45309 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
45310 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
45311 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
45312 C...Signed masses (extra minus from going to G-H convention).
45318 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
45319 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
45320 C...Signed masses (extra minus from going to G-H convention).
45324 C... Neutralino Mixing.
45326 ZMIX(IN,1)= SUPER(38+4*(IN-1))
45327 ZMIX(IN,2)= SUPER(37+4*(IN-1))
45328 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
45329 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
45331 C...Chargino Mixing (PYTHIA same angle as HERWIG).
45334 IF (SUPER(53).GT.0) THX=-1D0
45335 IF (SUPER(54).GT.0) THY=-1D0
45336 UMIX(1,1) = -SIN(SUPER(53))
45337 UMIX(1,2) = -COS(SUPER(53))
45338 UMIX(2,1) = -THX*COS(SUPER(53))
45339 UMIX(2,2) = THX*SIN(SUPER(53))
45340 VMIX(1,1) = -SIN(SUPER(54))
45341 VMIX(1,2) = -COS(SUPER(54))
45342 VMIX(2,1) = -THY*COS(SUPER(54))
45343 VMIX(2,2) = THY*SIN(SUPER(54))
45344 C...Sfermion mixing (PYTHIA same angle as ISAJET)
45345 SFMIX(5,1)=COS(SUPER(63))
45346 SFMIX(5,2)=SIN(SUPER(63))
45347 SFMIX(5,3)=-SIN(SUPER(63))
45348 SFMIX(5,4)=COS(SUPER(63))
45349 SFMIX(6,1)=COS(SUPER(61))
45350 SFMIX(6,2)=SIN(SUPER(61))
45351 SFMIX(6,3)=-SIN(SUPER(61))
45352 SFMIX(6,4)=COS(SUPER(61))
45353 SFMIX(15,1)=COS(SUPER(65))
45354 SFMIX(15,2)=SIN(SUPER(65))
45355 SFMIX(15,3)=-SIN(SUPER(65))
45356 SFMIX(15,4)=COS(SUPER(65))
45358 IF (MSTP(122).NE.0) THEN
45359 C...Print a few lines to make the user know what's happening
45361 WRITE(MSTU(11),5000) DOC, ISAVER
45362 WRITE(MSTU(11),5100)
45363 IF (IMODEL.EQ.1) THEN
45364 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
45366 WRITE(MSTU(11),5300)
45368 WRITE(MSTU(11),5500) 'Pole masses'
45369 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
45370 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
45371 & ,(SUPER(IP),IP=19,25,2)
45372 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
45374 WRITE(MSTU(11),5400)
45375 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
45376 WRITE(MSTU(11),5400)
45377 WRITE(MSTU(11),5500) 'EW scale mixing structure'
45378 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45379 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45380 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45381 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45382 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45383 & ),(SFMIX(15,J),J=3,4)
45384 WRITE(MSTU(11),5400)
45385 WRITE(MSTU(11),6450) RMSS(18)
45386 WRITE(MSTU(11),5400)
45387 WRITE(MSTU(11),5500) 'Couplings'
45388 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
45389 WRITE(MSTU(11),5400)
45392 C...Call FeynHiggs to improve Higgs sector if requested
45393 IF (IMSS(4).EQ.3) THEN
45394 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
45395 & ' (PYSUGI:) Now calling FeynHiggs.'
45397 IF (IERR.EQ.0) THEN
45399 IF (MSTP(122).NE.0) THEN
45400 WRITE(MSTU(11),5400)
45401 WRITE(MSTU(11),5500)
45402 & 'Corrected Higgs masses and mixing'
45403 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
45405 WRITE(MSTU(11),6450) RMSS(18)
45406 WRITE(MSTU(11),5400)
45411 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
45413 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
45414 C...output by ISASUSY.
45415 IMSS(4)=MAX(2,IMSS(4))
45417 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
45418 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
45419 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
45420 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
45421 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45422 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45423 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
45424 & ,'----------------')
45425 5400 FORMAT(1x,'*',1x,A)
45426 5500 FORMAT(1x,'*',1x,A,':')
45427 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45428 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45429 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
45430 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
45431 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
45433 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
45434 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
45435 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
45437 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45438 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45439 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45440 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
45441 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
45442 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
45443 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
45444 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45445 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45446 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45447 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45448 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45449 & ,1x,F6.3,1x),'|')
45450 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45451 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45452 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45453 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45454 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45455 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45456 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45457 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45458 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45459 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45460 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45461 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45462 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
45463 & ,4x,'Alpha_GUT = ',F8.2)
45464 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
45465 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
45470 C*********************************************************************
45473 C...Interface to FeynHiggs for MSSM Higgs sector.
45474 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
45477 SUBROUTINE PYFEYN(IERR)
45479 C...Double precision and integer declarations.
45480 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45481 IMPLICIT INTEGER(I-N)
45482 INTEGER PYK,PYCHGE,PYCOMP
45484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45487 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45488 C...FeynHiggs variables
45489 DOUBLE PRECISION RMHIGG(4)
45490 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
45491 DOUBLE COMPLEX DMU,
45492 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
45494 C...SLHA Common Block
45495 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45496 & AU(3,3),AD(3,3),AE(3,3)
45497 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
45500 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
45501 IF (IERR.NE.0) THEN
45502 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
45503 & //'Will not use FeynHiggs for this run.')
45541 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
45542 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
45543 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
45544 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
45545 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
45546 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
45547 IF (IERR.NE.0) THEN
45548 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
45549 & //' Will not use FeynHiggs for this run.')
45552 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
45554 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
45555 IF (IERR.NE.0) THEN
45556 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
45557 & 'GSCORR. Will not use FeynHiggs for this run.')
45560 ALPHA = ASIN(DBLE(SAEFF))
45562 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
45563 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
45564 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
45565 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
45567 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
45568 & 1.15D0*PMAS(25,1)) THEN
45569 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
45570 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
45571 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
45574 PMAS(25,1)=RMHIGG(1)
45575 PMAS(35,1)=RMHIGG(2)
45576 PMAS(36,1)=RMHIGG(3)
45577 PMAS(37,1)=RMHIGG(4)
45582 C*********************************************************************
45585 C...Determines the running mass of Squarks.
45587 FUNCTION PYRNMQ(ID,DTERM)
45589 C...Double precision and integer declarations.
45590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45591 IMPLICIT INTEGER(I-N)
45592 INTEGER PYK,PYCHGE,PYCOMP
45594 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45597 C...Local variables.
45598 DOUBLE PRECISION PI,R
45599 DOUBLE PRECISION TOL
45600 DOUBLE PRECISION CI(3)
45602 DOUBLE PRECISION PYALPS
45604 DATA PI,R/3.141592654D0,.61803399D0/
45605 DATA CI/0.47D0,0.07D0,0.02D0/
45609 AG=(0.71D0)**2/4D0/PI
45616 AS=PYALPS(XM02+6D0*XMG2)
45617 CG=8D0/9D0*((AS/AG)**2-1D0)
45618 BX=XM02+(CA+CG)*XMG2+DTERM
45619 AX=MIN(50D0**2,0.5D0*BX)
45620 CX=MAX(2000D0**2,2D0*BX)
45624 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
45632 CG=8D0/9D0*((AS1/AG)**2-1D0)
45633 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
45635 CG=8D0/9D0*((AS2/AG)**2-1D0)
45636 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
45637 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
45644 CG=8D0/9D0*((AS2/AG)**2-1D0)
45645 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
45652 CG=8D0/9D0*((AS1/AG)**2-1D0)
45653 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
45668 C*********************************************************************
45671 C...Calculates the mass eigenstates of the third generation sfermions.
45672 C...Created: 5-31-96
45676 C...Double precision and integer declarations.
45677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45678 IMPLICIT INTEGER(I-N)
45679 INTEGER PYK,PYCHGE,PYCOMP
45680 C...Parameter statement to help give large particle numbers.
45681 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45682 &KEXCIT=4000000,KDIMEN=5000000)
45684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45686 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45687 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45688 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45689 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
45691 C...Local variables.
45692 DOUBLE PRECISION BETA
45693 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
45694 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
45695 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
45696 DOUBLE PRECISION ATR,AMQR,AMQL
45697 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
45698 INTEGER IF,I,J,II,JJ,IT,L
45712 COS2B=COS(2D0*BETA)
45714 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
45724 XMQL2=CTT2*XM12+STT2*XM22
45725 XMQR2=STT2*XM12+CTT2*XM22
45726 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
45727 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45729 C......SUBTRACT OUT D-TERM AND FERMION MASS
45730 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
45731 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
45732 IF(XMQL2.GE.0D0) THEN
45733 RMSS(10)=SQRT(XMQL2)
45735 RMSS(10)=-SQRT(-XMQL2)
45737 IF(XMQR2.GE.0D0) THEN
45738 RMSS(12)=SQRT(XMQR2)
45740 RMSS(12)=-SQRT(-XMQR2)
45743 C SAME FOR BOTTOM SQUARK
45749 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
45750 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
45751 IF(ABS(CTT).GE..9999D0) THEN
45754 ELSEIF(ABS(CTT).LE.1D-4) THEN
45758 XM12=(XMQL2-STT2*XM22)/CTT2
45759 XMQR2=STT2*XM12+CTT2*XM22
45760 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45763 C......SUBTRACT OUT D-TERM AND FERMION MASS
45764 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
45765 IF(XMQR2.GE.0D0) THEN
45766 RMSS(11)=SQRT(XMQR2)
45768 RMSS(11)=-SQRT(-XMQR2)
45770 C SAME FOR TAU SLEPTON
45777 XMQL2=CTT2*XM12+STT2*XM22
45778 XMQR2=STT2*XM12+CTT2*XM22
45781 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45783 C......SUBTRACT OUT D-TERM AND FERMION MASS
45784 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
45785 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
45786 IF(XMQL2.GE.0D0) THEN
45787 RMSS(13)=SQRT(XMQL2)
45789 RMSS(13)=-SQRT(-XMQL2)
45791 IF(XMQR2.GE.0D0) THEN
45792 RMSS(14)=SQRT(XMQR2)
45794 RMSS(14)=-SQRT(-XMQR2)
45799 IF(AMQL.LT.0D0) THEN
45806 IF(AMQR.LT.0D0) THEN
45812 XMF=PYMRUN(IF,PMAS(6,1)**2)
45814 AM2(1,1)=XMQL2+XMF2
45815 AM2(2,2)=XMQR2+XMF2
45816 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
45819 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
45820 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
45821 AM2(1,2)=XMF*(ATR+XMU*TANB)
45822 ELSEIF(L.EQ.2) THEN
45823 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
45824 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
45825 AM2(1,2)=XMF*(ATR+XMU/TANB)
45826 ELSEIF(L.EQ.3) THEN
45827 IF(IMSS(8).EQ.1) THEN
45828 AM2(1,1)=RMSS(6)**2
45829 AM2(2,2)=RMSS(7)**2
45834 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
45835 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
45836 AM2(1,2)=XMF*(ATR+XMU*TANB)
45841 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
45842 IF(DETM.LT.0D0) THEN
45843 WRITE(MSTU(11),*) ID2(L),DETM,AM2
45844 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
45846 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
45847 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
45851 IF(XMF22-XMF12.GT.0D0) THEN
45852 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
45854 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
45855 & AM2(1,2)/(XMF22-XMF12))
45871 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
45877 IF(DI(1,1).GT.DI(2,2)) THEN
45878 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
45879 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
45880 WRITE(MSTU(11),*) AM2
45881 WRITE(MSTU(11),*) DI
45882 WRITE(MSTU(11),*) RT
45893 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
45894 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
45895 & ' OFF DIAGONAL ELEMENTS '
45896 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
45897 WRITE(MSTU(11),*) DI
45898 WRITE(MSTU(11),*) ' ROTATION = ',RT
45900 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
45901 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
45902 & ' NEGATIVE MASSES '
45905 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
45906 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
45907 SFMIX(IF,1)=RT(1,1)
45908 SFMIX(IF,2)=RT(1,2)
45909 SFMIX(IF,3)=RT(2,1)
45910 SFMIX(IF,4)=RT(2,2)
45913 C.....TAU SNEUTRINO MASS...L=3
45915 XARG=AM2(1,1)+XMW2*COS2B
45916 IF(XARG.LT.0D0) THEN
45917 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
45918 & ' FROM THE SUM RULE. '
45919 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45922 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
45928 C*********************************************************************
45931 C...Finds the mass eigenstates and mixing matrices for neutralinos
45936 C...Double precision and integer declarations.
45937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45938 IMPLICIT INTEGER(I-N)
45940 C...Parameter statement to help give large particle numbers.
45941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45942 &KEXCIT=4000000,KDIMEN=5000000)
45944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45947 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45948 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45949 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
45951 C...Local variables.
45952 DOUBLE PRECISION XMW,XMZ,XM(4)
45953 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
45954 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
45955 DOUBLE PRECISION COSW,SINW
45956 DOUBLE PRECISION XMU
45957 DOUBLE PRECISION TANB,COSB,SINB
45958 DOUBLE PRECISION XM1,XM2,XM3,BETA
45959 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
45960 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
45961 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
45962 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
45963 DOUBLE PRECISION PYALPS,PYALEM
45964 DOUBLE PRECISION PYRNM3
45965 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
45966 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
45967 DATA KFNCHI/1000022,1000023,1000025,1000035/
45970 IF(IMSS(1).EQ.2) THEN
45973 C...M1, M2, AND M3 ARE INDEPENDENT
45978 ELSEIF(IOPT.GE.1) THEN
45982 A1=AEM/(1D0-PARU(102))
45985 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
45987 XM2=XM1*A2/A1*3D0/5D0
45989 ELSEIF(IOPT.EQ.3) THEN
45990 XM1=XM2*5D0/3D0*A1/A2
45995 IF(XM3.LE.0D0) THEN
45996 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
46002 IF(IMSS(3).EQ.1) THEN
46003 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
46008 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
46009 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
46010 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
46016 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
46017 RM2=PMAS(I,1)**2/XM3**2
46018 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
46019 IF(ARG.GE.0D0) THEN
46020 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
46022 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
46027 ELSEIF(X0.EQ.0D0) THEN
46031 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
46032 & 0.5D0*X0**2*LOG(AX0)
46033 BT=(-1D0-2D0*X0)/4D0
46038 ELSEIF(X1.EQ.0D0) THEN
46042 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
46043 & X1**2*LOG(AX1)+AT
46044 BT=(-1D0-2D0*X1)/4D0+BT
46048 X0=0.5D0*(1D0+RM2-RM1)
46049 Y0=-0.5D0*SQRT(-ARG)
46050 AMGX0=SQRT(X0**2+Y0**2)
46051 AM1X0=SQRT((1D0-X0)**2+Y0**2)
46052 ARGX0=ATAN2(-X0,-Y0)
46053 AR1X0=ATAN2(1D0-X0,Y0)
46058 ARGX1=ATAN2(-X1,-Y1)
46059 AR1X1=ATAN2(1D0-X1,Y1)
46060 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
46061 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
46062 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
46063 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
46064 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
46065 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
46070 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
46071 & /(2D0*PARU(2))*(15D0+AQ))
46074 C...NEUTRALINO MASSES
46083 SINW=SQRT(PARU(102))
46084 COSW=SQRT(1D0-PARU(102))
46091 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
46092 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
46093 AR(1,1) = XM1*COS(RMSS(30))
46094 AI(1,1) = XM1*SIN(RMSS(30))
46095 AR(2,2) = XM2*COS(RMSS(31))
46096 AI(2,2) = XM2*SIN(RMSS(31))
46101 AR(1,3) = -XMZ*SINW*COSB
46103 AR(1,4) = XMZ*SINW*SINB
46105 AR(2,3) = XMZ*COSW*COSB
46107 AR(2,4) = -XMZ*COSW*SINB
46109 AR(3,4) = -XMU*COS(RMSS(33))
46110 AI(3,4) = -XMU*SIN(RMSS(33))
46111 AR(4,3) = -XMU*COS(RMSS(33))
46112 AI(4,3) = -XMU*SIN(RMSS(33))
46113 C CALL PYEIG4(AR,WR,ZR)
46114 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46116 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46125 IF(XM(K).LT.XM(J)) THEN
46143 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
46146 S=S+ZR(J,K)**2+ZI(J,K)**2
46149 ZMIX(I,J)=ZR(J,K)/SQRT(S)
46150 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
46151 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
46152 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
46156 C...CHARGINO MASSES
46157 C.....Find eigenvectors of X X^*
46160 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
46161 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
46162 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
46163 &XMU*COS(RMSS(33))*SINB)
46164 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
46165 &XMU*SIN(RMSS(33))*SINB)
46166 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
46167 &XMU*COS(RMSS(33))*SINB)
46168 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
46169 &XMU*SIN(RMSS(33))*SINB)
46170 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46172 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46176 IF(WR(2).LT.WR(1)) THEN
46186 S=S+ZR(J,K)**2+ZI(J,K)**2
46189 UMIX(I,J)=ZR(J,K)/SQRT(S)
46190 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
46191 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
46192 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
46195 C...Force chargino mass > neutralino mass
46196 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
46197 CALL PYERRM(18,'(PYINOM:) '//
46198 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
46199 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
46201 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
46202 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
46204 C.....Find eigenvectors of X^* X
46207 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
46208 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
46209 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
46210 &XMU*COS(RMSS(33))*COSB)
46211 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
46212 &XMU*SIN(RMSS(33))*COSB)
46213 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
46214 &XMU*COS(RMSS(33))*COSB)
46215 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
46216 &XMU*SIN(RMSS(33))*COSB)
46217 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46219 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46223 IF(WR(2).LT.WR(1)) THEN
46232 S=S+ZR(J,K)**2+ZI(J,K)**2
46235 VMIX(I,J)=ZR(J,K)/SQRT(S)
46236 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
46237 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
46238 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
46246 C*********************************************************************
46249 C...Calculates the running of M3, the SU(3) gluino mass parameter.
46251 FUNCTION PYRNM3(RGUT)
46253 C...Double precision and integer declarations.
46254 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46255 IMPLICIT INTEGER(I-N)
46256 INTEGER PYK,PYCHGE,PYCOMP
46258 C...Local variables.
46260 DOUBLE PRECISION TOL
46262 DOUBLE PRECISION PYALPS
46264 DATA R/0.61803399D0/
46268 BX=RGUT*PYALPS(RGUT**2)
46269 AX=MIN(50D0,BX*0.5D0)
46270 CX=MAX(2000D0,2D0*BX)
46274 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46282 F1=ABS(X1-RGUT*AS1)
46284 F2=ABS(X2-RGUT*AS2)
46285 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46292 F2=ABS(X2-RGUT*AS2)
46299 F1=ABS(X1-RGUT*AS1)
46314 C*********************************************************************
46317 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
46318 C...Specific application: mixing in neutralino sector.
46320 SUBROUTINE PYEIG4(A,W,Z)
46322 C...Double precision and integer declarations.
46323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46324 IMPLICIT INTEGER(I-N)
46325 INTEGER PYK,PYCHGE,PYCOMP
46327 C...Arrays: in call and local.
46328 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
46330 C...Coefficients of fourth-degree equation from matrix.
46331 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
46332 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
46336 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
46345 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
46346 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
46347 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
46348 B0=B0+(-1D0)**(I+1)*A(1,I)*(
46349 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
46350 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
46351 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
46354 C...Coefficients of third-degree equation needed for
46355 C...separation into two second-degree equations.
46356 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
46359 C0=-B1**2-B0*B3**2+4D0*B0*B2
46360 CQ=C1/3D0-C2**2/9D0
46361 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
46364 C...Cases with one or three real roots.
46365 IF(CQR.GE.0D0) THEN
46366 S1=(CR+SQRT(CQR))**(1D0/3D0)
46367 S2=(CR-SQRT(CQR))**(1D0/3D0)
46371 THE=ACOS(CR/SABS**3)/3D0
46376 C...Find and solve two second-degree equations.
46377 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
46378 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
46379 Q1=U/2D0+SQRT(U**2/4D0-B0)
46380 Q2=U/2D0-SQRT(U**2/4D0-B0)
46381 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
46386 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
46387 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
46388 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
46389 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
46391 C...Order eigenvalues in asceding mass.
46394 DO 130 I2=I1-1,1,-1
46395 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
46401 C...Find equation system for eigenvectors.
46404 D(J1,J1)=A(J1,J1)-W(I)
46411 C...Find largest element in matrix.
46415 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
46418 DAMAX=ABS(D(J1,J2))
46422 C...Subtract others by multiple of row selected above.
46424 DO 210 J3=JA+1,JA+3
46426 RL=D(J1,JB)/D(JA,JB)
46428 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
46429 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
46432 DAMAX=ABS(D(J1,J2))
46436 C...Do one more subtraction of a row.
46438 DO 230 J3=JC+1,JC+3
46440 IF(J1.EQ.JA) GOTO 230
46441 RL=D(J1,JD)/D(JC,JD)
46443 IF(J2.EQ.JB) GOTO 220
46444 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
46445 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
46447 DAMAX=ABS(D(J1,J2))
46451 C...Construct unnormalized eigenvector.
46453 JF2=JD+2-4*((JD+1)/4)
46454 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
46455 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
46458 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
46459 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
46462 C...Normalize and fill in final array.
46463 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
46464 SGN=(-1D0)**INT(PYR(0)+0.5D0)
46473 C*********************************************************************
46476 C...Determines the Higgs boson mass spectrum using several inputs.
46478 SUBROUTINE PYHGGM(ALPHA)
46480 C...Double precision and integer declarations.
46481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46482 IMPLICIT INTEGER(I-N)
46483 INTEGER PYK,PYCHGE,PYCOMP
46484 C...Parameter statement to help give large particle numbers.
46485 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46486 &KEXCIT=4000000,KDIMEN=5000000)
46488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46490 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46491 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46492 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
46494 C...Local variables.
46495 DOUBLE PRECISION AT,AB,XMU,TANB
46496 DOUBLE PRECISION ALPHA
46498 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
46499 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
46500 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
46501 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
46504 IF(IHOPT.EQ.2) THEN
46520 DMC=PMAS(PYCOMP(KSUSY1+37),1)
46527 IF(IHOPT.EQ.0) THEN
46528 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
46529 & DMHCH,DSA,DCA,DTANBA)
46530 ELSEIF(IHOPT.EQ.1) THEN
46531 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
46532 & DMHCH,DSA,DCA,DTANBA)
46533 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
46534 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
46535 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
46541 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
46542 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
46543 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
46544 & PMAS(PYCOMP(1000006),1),DSTOP2
46546 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
46547 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
46548 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
46549 & PMAS(PYCOMP(2000006),1),DSTOP1
46551 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
46552 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
46553 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
46554 & PMAS(PYCOMP(1000005),1),DSBOT2
46556 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
46557 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
46558 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
46559 & PMAS(PYCOMP(2000005),1),DSBOT1
46562 ELSEIF (IHOPT.EQ.3) THEN
46563 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
46564 C...Currently only available for SLHA spectrum read-in.
46565 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
46566 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
46567 & //' spectrum, change IMSS(1) or IMSS(4) option.')
46583 C*********************************************************************
46586 C...This routine computes the renormalization group improved
46587 C...values of Higgs masses and couplings in the MSSM.
46589 C...Program based on the work by M. Carena, J.R. Espinosa,
46590 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
46592 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
46593 C...All masses in GeV units. MA is the CP-odd Higgs mass,
46594 C...MTOP is the physical top mass, MQ and MUR are the soft
46595 C...supersymmetry breaking mass parameters of left handed
46596 C...and right handed stops respectively, AU and AD are the
46597 C...stop and sbottom trilinear soft breaking terms,
46598 C...respectively, and MU is the supersymmetric
46599 C...Higgs mass parameter. We use the conventions from
46600 C...the physics report of Haber and Kane: left right
46601 C...stop mixing term proportional to (AU - MU/TANB)
46602 C...We use as input TANB defined at the scale MTOP
46604 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
46605 C...where MH and HM are the lightest and heaviest CP-even
46606 C...Higgs masses, MHCH is the charged Higgs mass and
46607 C...ALPHA is the Higgs mixing angle
46608 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
46610 C...Range of validity:
46611 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
46612 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
46613 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
46614 C...are the sbottom mass eigenvalues, respectively. This
46615 C...range automatically excludes the existence of tachyons.
46616 C...For the charged Higgs mass computation, the method is
46618 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
46619 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
46620 C...where M_SUSY**2 is the average of the squared stop mass
46621 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
46622 C...masses have been assumed to be of order of the stop ones
46623 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
46625 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
46626 &XMHCH,SA,CA,TANBA)
46628 C...Double precision and integer declarations.
46629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46630 IMPLICIT INTEGER(I-N)
46631 INTEGER PYK,PYCHGE,PYCOMP
46632 C...Parameter statement to help give large particle numbers.
46633 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46634 &KEXCIT=4000000,KDIMEN=5000000)
46636 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46637 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46638 COMMON/PYHTRI/HHH(7)
46639 SAVE /PYDAT1/,/PYDAT2/
46641 C...Local variables.
46642 DOUBLE PRECISION PYALEM,PYALPS
46643 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
46644 DOUBLE PRECISION XMHCH,SA,CA
46645 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
46646 DOUBLE PRECISION Q02
46647 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
46648 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
46649 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
46650 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
46651 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
46652 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
46653 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
46654 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
46659 ALP1=AEM/(1D0-PARU(102))
46672 C...MBOTTOM(MTOP) = 3. GEV
46673 XMB = PYMRUN(5,XMTOP**2)
46674 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
46675 &LOG(XMTOP**2/XMZ**2))
46677 C...RMTOP= RUNNING TOP QUARK MASS
46678 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
46679 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
46680 T = LOG(XMS**2/XMTOP**2)
46681 SINB = TANB/((1D0 + TANB**2)**0.5D0)
46683 C...IF(MA.LE.XMTOP) TANBA = TANBT
46685 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
46686 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
46687 &LOG(XMA**2/XMTOP**2))
46689 SINBT = TANBT/SQRT(1D0 + TANBT**2)
46690 COSBT = 1D0/SQRT(1D0 + TANBT**2)
46691 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
46692 G1 = SQRT(ALP1*4D0*PI)
46693 G2 = SQRT(ALP2*4D0*PI)
46694 G3 = SQRT(ALP3*4D0*PI)
46709 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
46710 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
46711 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
46712 &+ 3D0*(AU + AD)**2/XMS2)/6D0
46713 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
46714 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
46715 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
46716 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
46717 &- 16D0*G3**2) *T/16D0/PI2)
46718 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
46719 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
46720 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
46721 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
46722 &- 16D0*G3**2) *T/16D0/PI2)
46723 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
46724 &(HU2 + HD2)*T/16D0/PI2)
46725 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
46726 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
46727 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
46728 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
46729 &- 16D0*G3**2) *T/16D0/PI2)
46730 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
46731 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
46732 &- 16D0*G3**2) *T/16D0/PI2)
46733 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
46734 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
46735 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
46736 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
46738 &(1+ (6D0*HU2 -2D0* HD2
46739 &- 16D0*G3**2) *T/16D0/PI2)
46740 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
46742 &(1+ (6D0*HD2 -2D0* HU2/2D0
46743 &- 16D0*G3**2) *T/16D0/PI2)
46744 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
46745 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
46746 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
46747 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
46748 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
46749 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46750 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
46751 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46752 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
46753 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46754 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
46755 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46763 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
46764 &2D0* XLAM6*SINBT*COSBT
46765 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
46767 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
46769 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
46770 &2D0* XLAM6* COSBT*SINBT
46771 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46772 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
46773 &((XLAM1* COSBT**2 +2D0*
46774 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
46775 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
46777 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
46778 &+ XLAM4) + XLAM6*COSBT**2
46779 &+ XLAM7* SINBT**2))
46781 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
46782 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
46785 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
46786 XMHCH = SQRT(XMHCH2)
46788 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
46789 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
46790 &XLAM6* COSBT*SINBT
46791 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
46792 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46793 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
46794 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
46796 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
46797 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
46798 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
46799 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
46800 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
46801 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
46802 &XLAM6* COSBT*SINBT
46803 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
46804 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46805 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
46815 C*********************************************************************
46818 C...This subroutine computes the CP-even higgs and CP-odd pole
46819 c...Higgs masses and mixing angles.
46821 C...Program based on the work by M. Carena, M. Quiros
46822 C...and C.E.M. Wagner, "Effective potential methods and
46823 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
46825 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
46827 C...where MCHI is the largest chargino mass, MA is the running
46828 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
46829 C...expectaion values at the scale MTOP, MQ is the third generation
46830 C...left handed squark mass parameter, MUR is the third generation
46831 C...right handed stop mass parameter, MDR is the third generation
46832 C...right handed sbottom mass parameter, MTOP is the pole top quark
46833 C...mass; AT,AB are the soft supersymmetry breaking trilinear
46834 C...couplings of the stop and sbottoms, respectively, and MU is the
46835 C...supersymmetric mass parameter
46837 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
46838 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
46839 C...masses are given, what makes the running of the program
46840 c...much faster and it is quite generally a good approximation
46841 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
46842 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
46843 c...and if IHIGGS=3, then h,H,A polarizations are computed
46845 C...Output: MH and MHP which are the lightest CP-even Higgs running
46846 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
46847 C...Higgs running and pole masses, repectively; SA and CA are the
46848 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
46849 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
46850 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
46851 C...the value of TANB at the CP-odd Higgs mass scale
46853 C...This subroutine makes use of CERN library subroutine
46854 C...integration package, which makes the computation of the
46855 C...pole Higgs masses somewhat faster. We thank P. Janot for this
46856 C...improvement. Those who are not able to call the CERN
46857 C...libraries, please use the subroutine SUBHPOLE2.F, which
46858 C...although somewhat slower, gives identical results
46860 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
46861 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
46863 C...Double precision and integer declarations.
46864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46865 IMPLICIT INTEGER(I-N)
46868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46870 INTEGER PYK,PYCHGE,PYCOMP
46872 C...Local variables.
46873 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
46874 &SSBOT2(2),B(2,2),COUPB(2,2),
46875 &HCOUPT(2,2),HCOUPB(2,2),
46876 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
46885 RXMT=PYMRUN(6,XMT**2)
46886 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
46887 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
46889 SINB = TANB/(TANB**2+1D0)**0.5D0
46890 COSB = 1D0/(TANB**2+1D0)**0.5D0
46891 COS2B = SINB**2 - COSB**2
46892 SINBPA = SINB*CA + COSB*SA
46893 COSBPA = COSB*CA - SINB*SA
46894 RMBOT = PYMRUN(5,XMT**2)
46897 IF(XMUR.LT.0D0) XMUR2=-XMUR2
46899 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
46900 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
46901 IF(XMST11.LT.0D0) GOTO 500
46902 IF(XMST22.LT.0D0) GOTO 500
46903 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
46904 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
46905 IF(XMSB11.LT.0D0) GOTO 500
46906 IF(XMSB22.LT.0D0) GOTO 500
46907 C WMST11 = RXMT**2 + XMQ2
46908 C WMST22 = RXMT**2 + XMUR2
46909 XMST12 = RXMT*(AT - XMU/TANB)
46910 XMSB12 = RMBOT*(AB - XMU*TANB)
46912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46913 C...STOP EIGENVALUES CALCULATION
46914 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46916 STOP12 = 0.5D0*(XMST11+XMST22) +
46917 &0.5D0*((XMST11+XMST22)**2 -
46918 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
46919 STOP22 = 0.5D0*(XMST11+XMST22) -
46920 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
46921 &XMST12**2))**0.5D0
46923 IF(STOP22.LT.0D0) GOTO 500
46926 STOP1 = STOP12**0.5D0
46927 STOP2 = STOP22**0.5D0
46931 IF(XMST12.EQ.0D0) XST11 = 1D0
46932 IF(XMST12.EQ.0D0) XST12 = 0D0
46933 IF(XMST12.EQ.0D0) XST21 = 0D0
46934 IF(XMST12.EQ.0D0) XST22 = 1D0
46936 IF(XMST12.EQ.0D0) GOTO 110
46938 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
46939 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
46940 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
46941 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
46948 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
46949 &0.5D0*((XMSB11+XMSB22)**2 -
46950 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
46951 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
46952 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
46953 &XMSB12**2))**0.5D0
46954 IF(SBOT22.LT.0D0) GOTO 500
46955 SBOT1 = SBOT12**0.5D0
46956 SBOT2 = SBOT22**0.5D0
46961 IF(XMSB12.EQ.0D0) XSB11 = 1D0
46962 IF(XMSB12.EQ.0D0) XSB12 = 0D0
46963 IF(XMSB12.EQ.0D0) XSB21 = 0D0
46964 IF(XMSB12.EQ.0D0) XSB22 = 1D0
46966 IF(XMSB12.EQ.0D0) GOTO 130
46968 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
46969 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
46970 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
46971 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
46983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46984 C...STARTING OF LIGHT HIGGS
46985 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46987 IF(IHIGGS.EQ.0) GOTO 490
46992 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
46993 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
46994 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
46995 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
47004 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
47005 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
47006 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
47007 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
47015 180 ITER = ITER + 1
47018 PR(I3)=PRUN+(I3-2)*EPS/2
47023 POLT = POLT + COUPT(I,J)**2*3D0*
47024 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47031 POLB = POLB + COUPB(I,J)**2*3D0*
47032 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47039 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47041 & (-2D0*XMT**2+0.5D0*P2)*
47042 & PYFINT(P2,XMT2,XMT2)
47044 POL = POLT + POLB + POLTT
47045 POLAR(I3) = P2 - XMH**2 - POL
47047 DERIV = (POLAR(3)-POLAR(1))/EPS
47048 DRUN = - POLAR(2)/DERIV
47051 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
47057 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47058 C...END OF LIGHT HIGGS
47059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47061 250 IF(IHIGGS.EQ.1) GOTO 490
47063 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47064 C... STARTING OF HEAVY HIGGS
47065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47070 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
47071 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
47072 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
47073 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
47081 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
47082 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
47083 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
47084 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
47093 300 ITER = ITER + 1
47095 PR(I3)=PRUN+(I3-2)*EPS/2
47101 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
47102 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47109 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
47110 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47118 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47120 & (-2D0*XMT**2+0.5D0*HP2)*
47121 & PYFINT(HP2,XMT2,XMT2)
47123 HPOL = HPOLT + HPOLB + HPOLTT
47124 POLAR(I3) =HP2-HM**2-HPOL
47126 DERIV = (POLAR(3)-POLAR(1))/EPS
47127 DRUN = - POLAR(2)/DERIV
47130 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
47138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47139 C... END OF HEAVY HIGGS
47140 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47142 IF(IHIGGS.EQ.2) GOTO 490
47144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47145 C...BEGINNING OF PSEUDOSCALAR HIGGS
47146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47151 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
47152 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
47158 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
47159 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
47166 420 ITER = ITER + 1
47168 PR(I3)=PRUN+(I3-2)*EPS/2
47173 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
47174 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47180 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
47181 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47187 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47188 & COSB**2/SINB**2 *
47190 & PYFINT(AP2,XMT2,XMT2)
47191 APOL = APOLT + APOLB + APOLTT
47192 POLAR(I3) = AP2 - XMA**2 -APOL
47194 DERIV = (POLAR(3)-POLAR(1))/EPS
47195 DRUN = - POLAR(2)/DERIV
47198 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
47204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47205 C...END OF PSEUDOSCALAR HIGGS
47206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47208 IF(IHIGGS.EQ.3) GOTO 490
47213 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
47214 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
47215 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
47216 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
47220 C*********************************************************************
47223 C...Auxiliary to PYPOLE.
47225 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
47226 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
47227 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
47228 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
47231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47242 C MBOTTOM(MTOP) = 3. GEV
47243 MB = PYMRUN(5,MTOP**2)
47244 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
47245 *LOG(MTOP**2/MZ**2))
47246 C RMTOP= RUNNING TOP QUARK MASS
47247 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
47248 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
47249 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
47250 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
47251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47253 C NEW DEFINITION, TGLU.
47255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47256 TGLU = LOG(MGLU**2/MTOP**2)
47257 SINB = TANB/DSQRT(1D0 + TANB**2)
47260 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
47261 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
47262 *LOG(MA**2/MTOP**2))
47263 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
47264 SINB = TANBT/SQRT(1D0 + TANBT**2)
47265 COSB = 1D0/DSQRT(1D0 + TANBT**2)
47266 G1 = SQRT(ALPHA1*4D0*PI)
47267 G2 = SQRT(ALPHA2*4D0*PI)
47268 G3 = SQRT(ALPHA3*4D0*PI)
47271 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
47272 *SBOT1,SBOT2,DELTAMT,DELTAMB)
47273 IF(MQ.GT.MUR) TP = TQ - TU
47274 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
47275 IF(MQ.GT.MUR) TDP = TU
47276 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
47277 IF(MQ.GT.MD) TPD = TQ - TD
47278 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
47279 IF(MQ.GT.MD) TDPD = TD
47280 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
47282 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
47283 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
47284 * HD**2*(G1**2/3D0+G2**2)*TPD
47286 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
47287 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
47288 * HU**2*(-G1**2/3D0+G2**2)*TP
47290 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47292 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
47293 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
47294 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
47298 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47301 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
47302 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
47303 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
47306 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
47307 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
47310 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
47311 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
47314 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
47315 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
47318 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
47319 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
47322 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
47323 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
47328 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
47329 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
47330 *(G2**2-G1**2/3D0)*TPD
47331 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
47332 *1D0/16D0/PI**2*G1**2*HU**2*TP
47333 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
47334 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
47335 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
47336 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
47338 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
47339 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
47340 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
47341 *+ (3D0*HD**2/2D0 + HU**2/2D0
47342 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
47343 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
47344 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
47345 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
47346 *(TP + TDP)/8D0/PI**2)
47347 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
47348 *+ (3D0*HU**2/2D0 + HD**2/2D0
47349 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
47350 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
47351 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
47352 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47353 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
47354 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
47355 LAMBDA4 = (- G2**2/2D0)*(1D0
47356 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
47357 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
47363 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
47364 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
47366 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
47367 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
47368 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
47369 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
47372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47373 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
47374 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47376 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
47378 IF(MCHI.GT.MSSUSY) GOTO 100
47379 IF(MCHI.LT.MTOP) MCHI=MTOP
47381 TCHAR=LOG(MSSUSY**2/MCHI**2)
47383 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
47384 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
47385 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
47387 DELTAM112=2D0*DELTAL12*V**2*COSB**2
47388 DELTAM222=2D0*DELTAL12*V**2*SINB**2
47389 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
47391 M2(1,1)=M2(1,1)+DELTAM112
47392 M2(2,2)=M2(2,2)+DELTAM222
47393 M2(1,2)=M2(1,2)+DELTAM122
47394 M2(2,1)=M2(2,1)+DELTAM122
47398 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47399 CCC END OF CHARGINOS/NEUTRALINOS
47400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47404 M2P(I,J) = M2(I,J) + VH(I,J)
47407 TRM2P = M2P(1,1) + M2P(2,2)
47408 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
47409 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
47410 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
47412 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
47414 IF(MH2P.LT.0.) GOTO 130
47416 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
47417 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
47418 IF(COS2ALPHA.GE.0.) THEN
47419 ALPHA = ASIN(SIN2ALPHA)/2D0
47421 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
47425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47427 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
47428 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
47429 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
47432 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47433 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
47434 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
47439 C*********************************************************************
47442 C...Auxiliary to PYRGHM.
47444 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
47445 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
47446 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
47447 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
47449 INTEGER MSTU,MSTJ,KCHG
47450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47452 SAVE /PYDAT1/,/PYDAT2/
47454 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
47456 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
47457 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
47459 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
47464 SINBA = TANBA/DSQRT(TANBA**2+1D0)
47465 COSBA = SINBA/TANBA
47467 SINB = TANB/DSQRT(TANB**2+1D0)
47473 SW = 1D0-MW**2/MZ**2
47476 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
47477 G2 = DSQRT(0.0336D0*4D0*PI)
47478 G1 = DSQRT(0.0101D0*4D0*PI)
47480 IF(MQ.GT.MUR) MST = MQ
47481 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
47483 MSUSYT = DSQRT(MST**2 + MTOP**2)
47485 IF(MQ.GT.MD) MSB = MQ
47486 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
47488 MB = PYMRUN(5,MSB**2)
47489 MSUSYB = DSQRT(MSB**2 + MB**2)
47490 TT = LOG(MSUSYT**2/MTOP**2)
47491 TB = LOG(MSUSYB**2/MTOP**2)
47493 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
47494 HT = RMTOP/(V*SINB)
47497 G32 = ALPHA3*4D0*PI
47498 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
47499 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
47500 AL2 = 3D0/8D0/PI**2*HT**2
47501 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
47502 C ALST = 3./8./PI**2*HTST**2
47503 AL1 = 3D0/8D0/PI**2*HB**2
47506 AL(1,2) = (AL2+AL1)/2D0
47507 AL(2,1) = (AL2+AL1)/2D0
47510 IF(MA.GT.MTOP) THEN
47511 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
47512 * LOG(MTOP**2/MA**2))
47515 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
47516 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
47517 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
47518 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
47523 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
47524 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
47525 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
47526 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
47530 SINBT = TANBST/DSQRT(1D0+TANBST**2)
47533 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
47534 COSBB = SINBB/TANBSB
47539 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
47540 MTOP2 = DSQRT(MTOP4)
47541 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
47542 * /(1D0+DELTAMB)**4
47543 MBOT2 = DSQRT(MBOT4)
47545 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
47546 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47547 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47548 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
47549 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
47550 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47551 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47552 * MQ2 - MUR2)**2*0.25D0
47553 * + MTOP2*(AT-XMU/TANBST)**2)
47554 IF(STOP22.LT.0.) GOTO 120
47555 SBOT12 = (MQ2 + MD2)*.5D0
47556 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47557 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47558 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47559 SBOT22 = (MQ2 + MD2)*.5D0
47560 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47561 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47562 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47563 IF(SBOT22.LT.0.) SBOT22 = 10000D0
47565 STOP1 = DSQRT(STOP12)
47566 STOP2 = DSQRT(STOP22)
47567 SBOT1 = DSQRT(SBOT12)
47568 SBOT2 = DSQRT(SBOT22)
47570 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47572 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
47573 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
47574 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
47575 C INDUCED CORRECTIONS.
47577 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47582 IF(X.EQ.Y) X = X - 0.00001D0
47583 IF(X.EQ.Z) X = X - 0.00002D0
47584 IF(Y.EQ.Z) Y = Y - 0.00003D0
47590 IF(X.EQ.Y) X = X - 0.00001D0
47591 IF(X.EQ.Z) X = X - 0.00002D0
47592 IF(Y.EQ.Z) Y = Y - 0.00003D0
47594 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
47595 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
47599 IF(X.EQ.Y) X = X - 0.00001D0
47600 IF(X.EQ.Z) X = X - 0.00002D0
47601 IF(Y.EQ.Z) Y = Y - 0.00003D0
47603 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
47605 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47607 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
47608 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
47609 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
47610 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
47611 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
47612 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
47613 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
47614 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
47615 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
47616 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
47617 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
47620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47622 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
47623 MTOP2 = DSQRT(MTOP4)
47624 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
47625 * /(1D0+DELTAMB)**4
47626 MBOT2 = DSQRT(MBOT4)
47628 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
47629 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47630 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47631 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
47632 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
47633 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47634 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47635 * MQ2 - MUR2)**2*0.25D0
47636 * + MTOP2*(AT-XMU/TANBST)**2)
47638 IF(STOP22.LT.0.) GOTO 120
47639 SBOT12 = (MQ2 + MD2)*.5D0
47640 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47641 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47642 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47643 SBOT22 = (MQ2 + MD2)*.5D0
47644 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47645 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47646 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47647 IF(SBOT22.LT.0.) GOTO 120
47650 STOP1 = DSQRT(STOP12)
47651 STOP2 = DSQRT(STOP22)
47652 SBOT1 = DSQRT(SBOT12)
47653 SBOT2 = DSQRT(SBOT22)
47655 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47657 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47660 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
47662 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
47663 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
47665 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
47667 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
47668 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
47670 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
47671 * (-.5D0*LOG(STOP12/STOP22)
47672 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
47673 * G(STOP12,STOP22))
47675 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
47676 * (.5D0*LOG(SBOT12/SBOT22)
47677 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
47678 * G(SBOT12,SBOT22))
47680 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
47681 * (MQ2+MBOT2)/(MD2+MBOT2))
47682 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
47683 * LOG(SBOT1**2/SBOT2**2)) +
47684 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
47685 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
47688 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
47689 * -STOP2**2))**2*G(STOP12,STOP22)
47691 VH3B(1,1)=VH3B(1,1)+
47692 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
47694 VH3T(1,1) = VH3T(1,1) +
47695 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
47697 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
47698 * (MQ2+MTOP2)/(MUR2+MTOP2))
47699 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
47700 * LOG(STOP1**2/STOP2**2)) +
47701 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
47702 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
47705 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
47706 * -SBOT2**2))**2*G(SBOT12,SBOT22)
47708 VH3T(2,2)=VH3T(2,2)+
47709 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
47710 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
47712 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
47713 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
47714 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
47717 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
47718 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
47719 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
47722 VH3T(1,2)=VH3T(1,2) +
47723 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
47725 VH3B(1,2)=VH3B(1,2) +
47726 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
47728 VH3T(2,1) = VH3T(1,2)
47729 VH3B(2,1) = VH3B(1,2)
47731 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
47732 C TU = LOG((MUR2+MTOP2)/MTOP2)
47733 C TQD = LOG((MQ2 + MB**2)/MB**2)
47734 C TD = LOG((MD2+MB**2)/MB**2)
47739 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
47740 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
47741 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
47742 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
47761 C*********************************************************************
47764 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
47766 FUNCTION PYFINT(A,B,C)
47768 C...Double precision and integer declarations.
47769 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47770 IMPLICIT INTEGER(I-N)
47771 INTEGER PYK,PYCHGE,PYCOMP
47773 COMMON/PYINTS/XXM(20)
47776 C...Local variables.
47778 DOUBLE PRECISION PYFISB
47785 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
47790 C*********************************************************************
47793 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
47797 C...Double precision and integer declarations.
47798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47799 IMPLICIT INTEGER(I-N)
47800 INTEGER PYK,PYCHGE,PYCOMP
47802 COMMON/PYINTS/XXM(20)
47805 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
47806 &(X*(XXM(2)-XXM(3))+XXM(3)))
47811 C*********************************************************************
47814 C...Calculates decays of sfermions.
47816 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
47818 C...Double precision and integer declarations.
47819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47820 IMPLICIT INTEGER(I-N)
47821 INTEGER PYK,PYCHGE,PYCOMP
47822 C...Parameter statement to help give large particle numbers.
47823 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47824 &KEXCIT=4000000,KDIMEN=5000000)
47826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47827 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47828 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47829 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47830 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47831 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47833 C...Local variables.
47834 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
47835 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
47837 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
47838 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
47839 DOUBLE PRECISION PYLAMF,XL
47840 DOUBLE PRECISION TANW,XW,AEM,C1,AS
47841 DOUBLE PRECISION AL,AR,BL,BR
47842 DOUBLE PRECISION CH1,CH2,CH3,CH4
47843 DOUBLE PRECISION XMBOT,XMTOP
47844 DOUBLE PRECISION XLAM(0:400)
47845 INTEGER IDLAM(400,3)
47846 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
47847 DOUBLE PRECISION SR2
47848 DOUBLE PRECISION CBETA,SBETA
47849 DOUBLE PRECISION CW
47850 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
47851 DOUBLE PRECISION COSA,SINA,TANB
47852 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
47853 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
47855 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
47856 DATA IGG/23,25,35,36/
47857 DATA PI/3.141592654D0/
47858 DATA SR2/1.4142136D0/
47859 DATA KFNCHI/1000022,1000023,1000025,1000035/
47860 DATA KFCCHI/1000024,1000037/
47862 C...COUNT THE NUMBER OF DECAY MODES
47866 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
47867 &KFIN.EQ.KSUSY2+16) RETURN
47873 TANW = SQRT(XW/(1D0-XW))
47878 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
47883 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
47884 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
47890 C...ILR is 1 for left and 2 for right.
47892 C...IFL is matching non-SUSY flavour.
47893 IFL=MOD(KFIN,KSUSY1)
47894 C...IDU is weak isospin, 1 for down and 2 for up.
47905 XMBOT=PYMRUN(5,XMI2)
47906 XMTOP=PYMRUN(6,XMI2)
47920 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
47922 IF(IMSS(11).EQ.1) THEN
47925 XMGR=PMAS(PYCOMP(IDG),1)
47926 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
47929 ELSEIF(IFL.EQ.6) THEN
47934 IF(XMI.GT.XMGR+XMF) THEN
47939 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
47943 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
47945 C...CHARGED DECAYS:
47947 C...DI -> U CHI1-,CHI2-
47951 C...UI -> D CHI1+,CHI2+
47958 IF(XMI.GE.AXMJ+XMFP) THEN
47965 ELSEIF(IFL.LT.6) THEN
47970 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
47971 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
47977 ELSEIF(IFL.LT.5) THEN
47982 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
47983 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
47987 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
47988 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
47989 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
47990 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
48006 XL=PYLAMF(XMI2,XMA2,XMB2)
48007 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
48008 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48009 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
48012 IDLAM(LKNT,1)=-KFCCHI(IX)
48013 IDLAM(LKNT,2)=IFL+1
48015 IDLAM(LKNT,1)=KFCCHI(IX)
48016 IDLAM(LKNT,2)=IFL-1
48027 IF(XMI.GE.AXMJ+XMF) THEN
48033 ELSEIF(IFL.LT.5) THEN
48036 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
48037 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
48038 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
48043 ELSEIF(IFL.LT.5) THEN
48046 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
48047 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
48048 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
48052 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
48053 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
48054 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
48055 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
48071 XL=PYLAMF(XMI2,XMA2,XMB2)
48072 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
48073 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48074 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
48075 IDLAM(LKNT,1)=KFNCHI(IX)
48081 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
48085 IF(ILR.EQ.1) GOTO 160
48087 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
48088 IF(XMI.LT.XMSF1+XMB) GOTO 160
48090 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
48093 ELSEIF(IG.EQ.25) THEN
48096 ELSEIF(IFL.EQ.6) THEN
48098 ELSEIF(IFL.LT.5) THEN
48104 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
48105 & XMF**2/XMW*COSA/SBETA
48106 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
48107 & XMF**2/XMW*COSA/SBETA
48109 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
48110 & XMF**2/XMW*(-SINA)/CBETA
48111 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
48112 & XMF**2/XMW*(-SINA)/CBETA
48116 ELSEIF(IFL.EQ.6) THEN
48118 ELSEIF(IFL.EQ.15) THEN
48123 C.........need to complexify
48125 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
48128 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
48134 ELSEIF(IG.EQ.35) THEN
48137 ELSEIF(IFL.EQ.6) THEN
48139 ELSEIF(IFL.LT.5) THEN
48145 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
48146 & XMF**2/XMW*SINA/SBETA
48147 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
48148 & XMF**2/XMW*SINA/SBETA
48150 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
48151 & XMF**2/XMW*COSA/CBETA
48152 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
48153 & XMF**2/XMW*COSA/CBETA
48157 ELSEIF(IFL.EQ.6) THEN
48159 ELSEIF(IFL.EQ.15) THEN
48164 C.........Need to complexify
48166 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
48169 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
48175 ELSEIF(IG.EQ.36) THEN
48180 ELSEIF(IFL.EQ.6) THEN
48182 ELSEIF(IFL.LT.5) THEN
48189 ELSEIF(IFL.EQ.6) THEN
48191 ELSEIF(IFL.EQ.15) THEN
48196 C.........Need to complexify
48198 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
48200 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
48206 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
48207 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
48208 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
48209 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48212 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48214 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
48217 IDLAM(LKNT,1)=KFIN-KSUSY1
48223 IF(MOD(IFL,2).EQ.0) THEN
48229 XMSF1=PMAS(PYCOMP(KF1),1)
48230 XMSF2=PMAS(PYCOMP(KF2),1)
48231 IF(XMI.GT.XMB+XMSF1) THEN
48232 IF(MOD(IFL,2).EQ.0) THEN
48234 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
48236 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
48240 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
48242 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
48245 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48247 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48250 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
48252 IF(XMI.GT.XMB+XMSF2) THEN
48253 IF(MOD(IFL,2).EQ.0) THEN
48255 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
48257 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
48261 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
48263 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
48266 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
48268 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48271 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
48276 IF(MOD(IFL,2).EQ.0) THEN
48282 XMSF1=PMAS(PYCOMP(KF1),1)
48283 XMSF2=PMAS(PYCOMP(KF2),1)
48284 IF(XMI.GT.XMB+XMSF1) THEN
48289 IF(MOD(IFL,2).EQ.0) THEN
48292 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
48293 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
48294 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
48295 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
48298 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
48299 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
48300 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
48301 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
48312 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
48313 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
48314 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
48315 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
48318 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
48319 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
48320 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
48321 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
48330 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48332 C.......Need to complexify
48333 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
48334 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
48335 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
48336 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
48339 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
48341 IF(XMI.GT.XMB+XMSF2) THEN
48346 IF(MOD(IFL,2).EQ.0) THEN
48349 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
48350 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
48351 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
48352 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
48355 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
48356 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
48357 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
48358 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
48369 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
48370 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
48371 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
48372 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
48375 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
48376 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
48377 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
48378 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
48387 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48389 C.......Need to complexify
48390 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
48391 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
48392 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
48393 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
48396 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
48399 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
48404 IF(IFL.EQ.6) XMF=PMAS(6,1)
48405 IF(IFL.EQ.5) XMF=PMAS(5,1)
48406 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
48408 IF(XMI.GE.AXMJ+XMF) THEN
48425 XL=PYLAMF(XMI2,XMA2,XMB2)
48426 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48427 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
48428 IDLAM(LKNT,1)=KSUSY1+21
48434 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
48435 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
48436 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
48437 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
48438 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
48439 C...M*M = C1**2 * G**2/(16PI**2)
48440 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
48442 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
48443 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
48444 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
48445 IDLAM(LKNT,1)=KSUSY1+22
48450 C...R-violating sfermion decays (SKANDS).
48451 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
48456 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
48457 XLAM(0)=XLAM(0)+XLAM(I)
48459 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
48464 C*********************************************************************
48467 C...Calculates gluino decay modes.
48469 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
48471 C...Double precision and integer declarations.
48472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48473 IMPLICIT INTEGER(I-N)
48474 INTEGER PYK,PYCHGE,PYCOMP
48475 C...Parameter statement to help give large particle numbers.
48476 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48477 &KEXCIT=4000000,KDIMEN=5000000)
48479 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48480 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48481 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48482 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48483 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48485 C COMMON/PYINTS/XXM(20)
48487 COMMON/PYINTC/XXC(10),CXC(8)
48488 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
48490 C...Local variables
48491 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
48492 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
48493 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48494 DOUBLE PRECISION PYLAMF,XL
48495 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
48496 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
48497 DOUBLE PRECISION XLAM(0:400)
48498 INTEGER IDLAM(400,3)
48499 INTEGER LKNT,IX,ILR,I,IKNT,IFL
48500 DOUBLE PRECISION SR2
48501 DOUBLE PRECISION GAM
48502 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
48503 EXTERNAL PYGAUS,PYXXZ6
48504 DOUBLE PRECISION PYGAUS,PYXXZ6
48505 DOUBLE PRECISION PREC
48506 INTEGER KFNCHI(4),KFCCHI(2)
48507 DATA PI/3.141592654D0/
48508 DATA SR2/1.4142136D0/
48510 DATA KFNCHI/1000022,1000023,1000025,1000035/
48511 DATA KFCCHI/1000024,1000037/
48513 C...COUNT THE NUMBER OF DECAY MODES
48515 IF(KFIN.NE.KSUSY1+21) RETURN
48519 TANW = SQRT(XW/(1D0-XW))
48529 XMI=SIGN(XMI,RMSS(3))
48531 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
48533 IF(IMSS(11).EQ.1) THEN
48536 XMGR=PMAS(PYCOMP(IDG),1)
48537 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
48538 IF(AXMI.GT.XMGR) THEN
48547 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
48551 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
48554 IF(AXMI.GE.AXMJ+XMF) THEN
48555 C...Minus sign difference from gluino-quark-squark feynman rules
48572 XL=PYLAMF(XMI2,XMA2,XMB2)
48573 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
48574 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
48575 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
48579 XLAM(LKNT)=XLAM(LKNT-1)
48580 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48581 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48587 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
48588 C...GLUINO -> NI Q QBAR
48592 IF(AXMI.GE.AXMJ) THEN
48594 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
48596 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
48603 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
48604 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
48610 T3I=SIGN(1D0,EI+1D-6)/2D0
48611 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
48612 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
48616 CXC(4)=DCONJG(GLIJ)
48620 CXC(8)=-DCONJG(GRIJ)
48622 S12MAX=(AXMI-AXMJ)**2
48623 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
48624 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
48626 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
48627 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
48628 IDLAM(LKNT,1)=KFNCHI(IX)
48632 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
48634 XLAM(LKNT)=XLAM(LKNT-1)
48635 IDLAM(LKNT,1)=KFNCHI(IX)
48640 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
48641 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
48642 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
48644 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
48645 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
48647 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
48650 IDLAM(LKNT,1)=KFNCHI(IX)
48653 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
48658 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
48659 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
48660 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
48664 T3I=SIGN(1D0,EI+1D-6)/2D0
48665 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
48666 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
48668 CXC(4)=DCONJG(GLIJ)
48670 CXC(8)=-DCONJG(GRIJ)
48671 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
48672 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
48674 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
48675 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
48676 IDLAM(LKNT,1)=KFNCHI(IX)
48680 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
48682 XLAM(LKNT)=XLAM(LKNT-1)
48683 IDLAM(LKNT,1)=KFNCHI(IX)
48688 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
48689 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
48691 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
48692 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
48693 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
48695 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
48696 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
48698 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
48701 IDLAM(LKNT,1)=KFNCHI(IX)
48704 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
48710 C...GLUINO -> CI Q QBAR'
48714 IF(AXMI.GE.AXMJ) THEN
48716 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
48717 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
48720 S12MAX=(AXMI-AXMJ)**2
48725 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
48726 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
48729 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
48731 CXC(1)=DCMPLX(0D0,0D0)
48732 CXC(3)=DCMPLX(0D0,0D0)
48733 CXC(5)=DCMPLX(0D0,0D0)
48734 CXC(7)=DCMPLX(0D0,0D0)
48735 CXC(2)=UMIXC(IX,1)*OLPP/SR2
48736 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
48737 CXC(6)=DCMPLX(0D0,0D0)
48738 CXC(8)=DCMPLX(0D0,0D0)
48739 IF(XXC(5).LT.AXMI) THEN
48741 ELSEIF(XXC(6).LT.AXMI) THEN
48746 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
48747 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
48749 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
48750 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
48751 IDLAM(LKNT,1)=KFCCHI(IX)
48755 XLAM(LKNT)=XLAM(LKNT-1)
48756 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48757 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48758 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48760 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
48762 XLAM(LKNT)=XLAM(LKNT-1)
48763 IDLAM(LKNT,1)=KFCCHI(IX)
48767 XLAM(LKNT)=XLAM(LKNT-1)
48768 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48769 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48770 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48776 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
48777 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
48778 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
48779 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
48780 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
48781 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
48782 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
48783 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
48784 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
48785 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
48786 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
48787 CALL PYTBBC(IX,100,XMI,GAM)
48790 IDLAM(LKNT,1)=KFCCHI(IX)
48794 XLAM(LKNT)=XLAM(LKNT-1)
48795 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48796 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48797 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48798 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
48799 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
48800 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
48801 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
48807 C...R-parity violating (3-body) decays.
48808 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
48813 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
48814 XLAM(0)=XLAM(0)+XLAM(I)
48816 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
48822 C*********************************************************************
48825 C...Calculates the three-body decay of gluinos into
48826 C...neutralinos and third generation fermions.
48828 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
48830 C...Double precision and integer declarations.
48831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48832 IMPLICIT INTEGER(I-N)
48833 INTEGER PYK,PYCHGE,PYCOMP
48834 C...Parameter statement to help give large particle numbers.
48835 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48836 &KEXCIT=4000000,KDIMEN=5000000)
48838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48840 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48841 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48842 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48843 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48845 C...Local variables.
48846 EXTERNAL PYSIMP,PYLAMF
48847 DOUBLE PRECISION PYSIMP,PYLAMF
48849 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
48850 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
48851 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
48852 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
48853 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
48854 DOUBLE PRECISION XLN1,XLN2,B1,B2
48855 DOUBLE PRECISION E,XMGLU,GAM
48856 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
48857 SAVE HRB,HLB,FLB,FRB
48858 DOUBLE PRECISION ALPHAW,ALPHAS
48859 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
48860 SAVE HLT,HRT,FLT,FRT
48861 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
48863 DOUBLE PRECISION AMBOT,SINC,COSC
48864 DOUBLE PRECISION AMTOP,SINA,COSA
48865 DOUBLE PRECISION SINW,COSW,TANW
48866 DOUBLE PRECISION ROT1(4,4)
48869 DATA IFIRST/.TRUE./
48872 SINB=TANB/SQRT(1D0+TANB**2)
48883 AMBOT=PYMRUN(5,XMGLU**2)
48884 AMTOP=PYMRUN(6,XMGLU**2)
48886 FAKT1=AMBOT/W2/AMW/COSB
48887 FAKT2=AMTOP/W2/AMW/SINB
48898 ROT1(2,1)=-ROT1(1,2)
48899 ROT1(2,2)=ROT1(1,1)
48902 ROT1(4,3)=-ROT1(3,4)
48903 ROT1(4,4)=ROT1(3,3)
48907 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
48912 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
48913 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
48914 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
48916 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
48917 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
48918 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
48919 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
48922 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
48923 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
48924 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
48925 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
48926 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
48927 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
48928 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
48932 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
48933 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
48934 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
48935 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
48939 IF(NINT(3D0*E).EQ.2) THEN
48946 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
48947 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
48956 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
48957 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
48963 SIN2D=SIND*COSD*2D0
48977 ALPHAW=PYALEM(XMG2)
48978 ALPHAS=PYALPS(XMG2)
48982 XM24=(XMG2+XM2)*(XM2+XMR2)
48984 SMAX=(XMG-ABS(XMR))**2
48985 XMQA=XMG2+2D0*XM2+XMR2
48987 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
48989 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
48991 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
48992 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
48993 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
48994 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
48995 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
48996 & +2D0*(FF*SIND2-HH*COSD2))*W
48997 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
48998 & +4D0*HFL*XM*XMR)*XLN1
48999 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
49000 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
49001 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
49002 & +8D0*HFL*XMQ4*SIN2D)*B1
49003 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
49004 & +4D0*HFR*XMR*XM)*XLN2
49005 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
49006 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
49007 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
49008 & -8D0*HFR*XMQ4*SIN2D)*B2
49009 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
49010 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
49011 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
49012 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
49013 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
49014 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
49015 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
49016 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
49017 G(5)=(2D0*(HH*COSD2-FF*SIND2)
49018 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
49019 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
49020 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
49021 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
49022 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
49023 & +COS2D*XM*(SBAR+XMG2-XMR2))
49024 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
49025 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
49026 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
49027 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
49028 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
49029 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
49030 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
49033 SUMME(LIN)=SUMME(LIN)+G(J)
49038 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
49039 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
49044 C*********************************************************************
49047 C...Calculates the three-body decay of gluinos into
49048 C...charginos and third generation fermions.
49050 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
49052 C...Double precision and integer declarations.
49053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49054 IMPLICIT INTEGER(I-N)
49055 INTEGER PYK,PYCHGE,PYCOMP
49056 C...Parameter statement to help give large particle numbers.
49057 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49058 &KEXCIT=4000000,KDIMEN=5000000)
49060 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49061 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49062 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49063 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49064 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49065 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49067 C...Local variables.
49068 EXTERNAL PYSIMP,PYLAMF
49069 DOUBLE PRECISION PYSIMP,PYLAMF
49071 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
49072 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
49073 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
49074 DOUBLE PRECISION SUMME(0:100),A(4,8)
49075 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
49076 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
49077 DOUBLE PRECISION XMGLU,GAM
49078 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
49079 &DDD(2),EEE(2),FFF(2)
49080 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
49081 DOUBLE PRECISION ALPHAW,ALPHAS
49082 DOUBLE PRECISION AMC(2)
49084 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
49085 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
49089 DATA IFIRST/.TRUE./
49092 SINB=TANB/SQRT(1D0+TANB**2)
49100 AMBOT=PYMRUN(5,XMGLU**2)
49101 AMTOP=PYMRUN(6,XMGLU**2)
49104 FAKT1=AMBOT/W2/AMW/COSB
49105 FAKT2=AMTOP/W2/AMW/SINB
49110 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
49111 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
49112 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
49113 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
49114 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
49115 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
49116 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
49117 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
49119 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
49120 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
49121 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
49122 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
49126 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
49127 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
49128 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
49129 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
49131 COS2A=COSA**2-SINA**2
49132 SIN2A=SINA*COSA*2D0
49133 COS2C=COSC**2-SINC**2
49134 SIN2C=SINC*COSC*2D0
49141 ALPHAW=PYALEM(XMG2)
49142 ALPHAS=PYALPS(XMG2)
49146 XMQ2=XMG2+XMT2+XMB2+XMR2
49147 XMQ4=XMG*XMT*XMB*XMR
49148 XMQ3=XMG2*XMR2+XMT2*XMB2
49149 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
49150 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
49152 XMST(1)=AMST(1)*AMST(1)
49153 XMST(2)=AMST(1)*AMST(1)
49154 XMST(3)=AMST(2)*AMST(2)
49155 XMST(4)=AMST(2)*AMST(2)
49156 XMSB(1)=AMSB(1)*AMSB(1)
49157 XMSB(2)=AMSB(2)*AMSB(2)
49158 XMSB(3)=AMSB(1)*AMSB(1)
49159 XMSB(4)=AMSB(2)*AMSB(2)
49161 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
49162 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
49163 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
49164 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
49165 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
49166 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
49167 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
49168 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
49170 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
49171 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
49172 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
49173 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
49174 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
49175 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
49176 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
49177 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
49179 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
49180 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
49181 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
49182 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
49183 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
49184 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
49185 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
49186 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
49188 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
49189 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
49190 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
49191 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
49192 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
49193 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
49194 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
49195 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
49197 SMAX=(XMG-ABS(XMR))**2
49198 SMIN=(XMB+XMT)**2+0.1D0
49201 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
49202 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
49204 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
49205 W=DSQRT(W)/2D0/SBAR
49206 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
49207 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
49208 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
49209 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
49210 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
49211 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
49212 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
49213 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
49214 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
49215 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
49216 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
49217 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
49218 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
49219 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
49220 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
49221 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
49222 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
49223 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
49224 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
49225 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
49226 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
49227 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
49228 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
49229 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
49230 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
49231 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
49232 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
49233 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
49234 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
49235 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
49236 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
49237 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
49238 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
49239 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
49240 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
49241 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
49242 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
49243 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
49244 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
49245 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
49246 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
49247 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
49248 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
49250 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
49251 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
49252 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
49253 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
49254 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
49255 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
49256 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
49257 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
49258 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
49259 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
49260 & -A(J,6)*(XMG2+XMR2-SBAR)
49261 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
49262 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
49263 & /(GRS+XMSB(J)+XMST(J))
49267 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
49268 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
49273 C*********************************************************************
49276 C...Calculates decay widths for the neutralinos (admixtures of
49277 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
49279 C...Input: KCIN = KF code for particle
49280 C...Output: XLAM = widths
49281 C... IDLAM = KF codes for decay particles
49282 C... IKNT = number of decay channels defined
49283 C...AUTHOR: STEPHEN MRENNA
49285 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
49286 C...when CHIGAMMA .NE. 0
49287 C...10 FEB 96: Calculate this decay for small tan(beta)
49289 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
49291 C...Double precision and integer declarations.
49292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49293 IMPLICIT INTEGER(I-N)
49294 INTEGER PYK,PYCHGE,PYCOMP
49295 C...Parameter statement to help give large particle numbers.
49296 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49297 &KEXCIT=4000000,KDIMEN=5000000)
49299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49301 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49302 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49304 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49305 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49306 C COMMON/PYINTS/XXM(20)
49308 COMMON/PYINTC/XXC(10),CXC(8)
49309 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49311 C...Local variables.
49312 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49313 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
49315 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
49316 &XMZ,XMZ2,AXMJ,AXMI
49317 DOUBLE PRECISION S12MIN,S12MAX
49318 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
49319 DOUBLE PRECISION PYLAMF,XL
49320 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
49321 DOUBLE PRECISION PYX2XH,PYX2XG
49322 DOUBLE PRECISION XLAM(0:400)
49323 INTEGER IDLAM(400,3)
49324 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
49325 INTEGER ITH(3),KF1,KF2
49327 DOUBLE PRECISION DH(3),EH(3)
49328 DOUBLE PRECISION SR2
49329 DOUBLE PRECISION CBETA,SBETA
49330 DOUBLE PRECISION GAMCON,XMT1,XMT2
49331 DOUBLE PRECISION PYALEM,PI,PYALPS
49332 DOUBLE PRECISION RAT1,RAT2
49333 DOUBLE PRECISION T3T,FCOL
49334 DOUBLE PRECISION ALFA,BETA,TANB
49335 DOUBLE PRECISION PYXXGA
49336 EXTERNAL PYGAUS,PYXXZ6
49337 DOUBLE PRECISION PYGAUS,PYXXZ6
49338 DOUBLE PRECISION PREC
49339 INTEGER KFNCHI(4),KFCCHI(2)
49343 DATA PI/3.141592654D0/
49344 DATA SR2/1.4142136D0/
49345 DATA KFNCHI/1000022,1000023,1000025,1000035/
49346 DATA KFCCHI/1000024,1000037/
49348 C...COUNT THE NUMBER OF DECAY MODES
49357 TANW = SQRT(XW/XW1)
49359 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
49361 IF(KFIN.EQ.KFNCHI(2)) IX=2
49362 IF(KFIN.EQ.KFNCHI(3)) IX=3
49363 IF(KFIN.EQ.KFNCHI(4)) IX=4
49383 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49388 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49389 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49393 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
49394 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
49396 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
49397 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
49401 GAMCON=AEM**3/8D0/PI/XMW2/XW
49402 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
49403 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
49404 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
49405 IDLAM(LKNT,1)=KSUSY1+22
49408 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
49412 C...GRAVITINO DECAY MODES
49414 IF(IMSS(11).EQ.1) THEN
49417 XMGR=PMAS(PYCOMP(IDG),1)
49420 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49421 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
49426 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
49428 IF(AXMI.GT.XMGR+XMZ) THEN
49433 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
49434 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
49435 & (1D0-XMZ2/XMI2)**4
49437 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
49442 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
49443 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
49445 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
49450 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
49451 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
49453 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
49458 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
49459 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
49461 IF(IX.EQ.1) GOTO 300
49469 C...CHI0_I -> CHI0_J + GAMMA
49470 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
49471 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
49472 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
49473 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
49474 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
49475 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
49476 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
49478 IDLAM(LKNT,1)=KFNCHI(IJ)
49481 GAMCON=AEM**3/8D0/PI/XMW2/XW
49482 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
49483 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
49484 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
49488 C...CHI0_I -> CHI0_J + Z0
49489 IF(AXMI.GE.AXMJ+XMZ) THEN
49491 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
49492 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
49494 GX2=ABS(OLPP)**2+ABS(ORPP)**2
49495 GLR=DBLE(OLPP*DCONJG(ORPP))
49496 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
49497 IDLAM(LKNT,1)=KFNCHI(IJ)
49500 ELSEIF(AXMI.GE.AXMJ) THEN
49507 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
49508 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
49510 C...CHARGED LEPTONS
49512 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49513 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49515 T3I=SIGN(1D0,EI+1D-6)/2D0
49516 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49517 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49518 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49519 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49521 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49522 CXC(4)=DCONJG(GLIJ)
49523 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49525 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49526 CXC(8)=-DCONJG(GRIJ)
49528 S12MAX=(AXMI-AXMJ)**2
49529 IF( XXC(5).LT.AXMI ) THEN
49532 IF(XXC(6).LT.AXMI ) THEN
49538 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
49540 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49541 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49542 IDLAM(LKNT,1)=KFNCHI(IJ)
49545 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
49547 XLAM(LKNT)=XLAM(LKNT-1)
49548 IDLAM(LKNT,1)=KFNCHI(IJ)
49554 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
49555 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
49556 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
49558 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
49559 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
49561 IF( XXC(5).LT.AXMI ) THEN
49564 IF(XXC(6).LT.AXMI ) THEN
49570 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
49572 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49573 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49574 IDLAM(LKNT,1)=KFNCHI(IJ)
49582 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49583 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49585 T3I=SIGN(1D0,EI+1D-6)/2D0
49586 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49587 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49588 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49589 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49591 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49592 CXC(4)=DCONJG(GLIJ)
49593 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49595 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49596 CXC(8)=-DCONJG(GRIJ)
49598 S12MAX=(AXMI-AXMJ)**2
49599 IF( XXC(5).LT.AXMI ) THEN
49602 IF( XXC(6).LT.AXMI ) THEN
49609 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49610 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49611 IDLAM(LKNT,1)=KFNCHI(IJ)
49615 XLAM(LKNT)=XLAM(LKNT-1)
49616 IDLAM(LKNT,1)=KFNCHI(IJ)
49621 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
49623 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
49624 IF( XXC(5).LT.AXMI ) THEN
49629 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49630 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49633 XLAM(LKNT)=XLAM(LKNT-1)
49635 IDLAM(LKNT,1)=KFNCHI(IJ)
49641 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49642 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49644 T3I=SIGN(1D0,EI+1D-6)/2D0
49645 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49646 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49647 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49648 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49650 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49651 CXC(4)=DCONJG(GLIJ)
49652 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49654 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49655 CXC(8)=-DCONJG(GRIJ)
49657 S12MAX=(AXMI-AXMJ)**2
49658 IF( XXC(5).LT.AXMI ) THEN
49661 IF( XXC(6).LT.AXMI ) THEN
49667 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49669 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49670 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49671 IDLAM(LKNT,1)=KFNCHI(IJ)
49674 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49676 XLAM(LKNT)=XLAM(LKNT-1)
49677 IDLAM(LKNT,1)=KFNCHI(IJ)
49683 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
49684 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
49685 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
49687 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
49688 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
49690 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
49691 IF(XXC(5).LT.AXMI) THEN
49693 ELSEIF(XXC(6).LT.AXMI) THEN
49698 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49700 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49701 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49702 IDLAM(LKNT,1)=KFNCHI(IJ)
49710 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49711 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49713 T3I=SIGN(1D0,EI+1D-6)/2D0
49714 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49715 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49716 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49717 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49719 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49720 CXC(4)=DCONJG(GLIJ)
49721 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49723 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49724 CXC(8)=-DCONJG(GRIJ)
49726 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
49727 IF(XXC(5).LT.AXMI) THEN
49729 ELSEIF(XXC(6).LT.AXMI) THEN
49735 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49737 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49738 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49739 IDLAM(LKNT,1)=KFNCHI(IJ)
49742 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49744 XLAM(LKNT)=XLAM(LKNT-1)
49745 IDLAM(LKNT,1)=KFNCHI(IJ)
49753 C...CHI0_I -> CHI0_J + H0_K
49760 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
49761 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
49762 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
49763 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
49764 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
49765 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
49766 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
49767 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
49769 XMH=PMAS(ITH(IH),1)
49771 IF(AXMI.GE.AXMJ+XMH) THEN
49773 XL=PYLAMF(XMI2,XMJ2,XMH2)
49774 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
49776 C...SIGN OF MASSES I,J
49778 IF(IH.EQ.3) XMK=-XMK
49779 GX2=ABS(F21K)**2+ABS(F12K)**2
49780 GLR=DBLE(F21K*DCONJG(F12K))
49781 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
49782 IDLAM(LKNT,1)=KFNCHI(IJ)
49783 IDLAM(LKNT,2)=ITH(IH)
49789 C...CHI0_I -> CHI+_J + W-
49794 IF(AXMI.GE.AXMJ+XMW) THEN
49796 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
49797 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
49798 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
49799 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
49800 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
49801 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
49802 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
49803 IDLAM(LKNT,1)=KFCCHI(IJ)
49807 XLAM(LKNT)=XLAM(LKNT-1)
49808 IDLAM(LKNT,1)=-KFCCHI(IJ)
49811 ELSEIF(AXMI.GE.AXMJ) THEN
49813 S12MAX=(AXMI-AXMJ)**2
49814 RT2I = 1D0/SQRT(2D0)
49815 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
49816 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
49817 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
49818 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
49819 CXC(5)=DCMPLX(0D0,0D0)
49820 CXC(7)=DCMPLX(0D0,0D0)
49824 T3I=SIGN(1D0,EI+1D-6)/2D0
49826 T3J=SIGN(1D0,EJ+1D-6)/2D0
49827 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
49828 & TANW+ZMIXC(IX,2)*T3J)*RT2I
49829 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
49830 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
49831 CXC(6)=DCMPLX(0D0,0D0)
49832 CXC(8)=DCMPLX(0D0,0D0)
49837 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
49838 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
49841 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
49842 IF(XXC(5).LT.AXMI) THEN
49844 ELSEIF(XXC(6).LT.AXMI) THEN
49849 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
49851 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49852 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49853 IDLAM(LKNT,1)=KFCCHI(IJ)
49857 XLAM(LKNT)=XLAM(LKNT-1)
49858 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49859 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49860 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49861 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
49863 XLAM(LKNT)=XLAM(LKNT-1)
49864 IDLAM(LKNT,1)=KFCCHI(IJ)
49868 XLAM(LKNT)=XLAM(LKNT-1)
49869 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49870 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49871 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49875 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
49876 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
49877 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
49879 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
49880 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
49882 IF(XXC(5).LT.AXMI) THEN
49885 IF(XXC(6).LT.AXMI) THEN
49890 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
49892 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49893 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49894 XLAM(LKNT)=XLAM(LKNT-1)
49895 IDLAM(LKNT,1)=KFCCHI(IJ)
49899 XLAM(LKNT)=XLAM(LKNT-1)
49900 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49901 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49902 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49905 C...NOW, DO THE QUARKS
49910 T3I=SIGN(1D0,EI+1D-6)/2D0
49912 T3J=SIGN(1D0,EJ+1D-6)/2D0
49913 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
49914 & TANW+ZMIXC(IX,2)*T3J)
49915 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
49916 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
49917 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49918 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
49919 IF(XXC(5).LT.AXMI) THEN
49922 IF(XXC(6).LT.AXMI) THEN
49927 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
49929 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
49930 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49931 IDLAM(LKNT,1)=KFCCHI(IJ)
49935 XLAM(LKNT)=XLAM(LKNT-1)
49936 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49937 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49938 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49939 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49941 XLAM(LKNT)=XLAM(LKNT-1)
49942 IDLAM(LKNT,1)=KFCCHI(IJ)
49946 XLAM(LKNT)=XLAM(LKNT-1)
49947 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49948 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49949 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49957 C...CHI0_I -> CHI+_I + H-
49963 IF(AXMI.GE.AXMJ+XMHP) THEN
49965 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
49966 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
49967 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
49968 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
49970 GX2=ABS(OLPP)**2+ABS(ORPP)**2
49971 GLR=DBLE(OLPP*DCONJG(ORPP))
49972 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
49973 IDLAM(LKNT,1)=KFCCHI(IJ)
49974 IDLAM(LKNT,2)=-ITHC
49977 XLAM(LKNT)=XLAM(LKNT-1)
49978 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49979 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49980 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49986 C...2-BODY DECAYS TO FERMION SFERMION
49988 IF(J.GE.7.AND.J.LE.10) GOTO 290
49991 XMSF1=PMAS(PYCOMP(KF1),1)
49992 XMSF2=PMAS(PYCOMP(KF2),1)
50002 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
50003 IF(MOD(J,2).EQ.0) THEN
50004 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
50005 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50006 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50009 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
50010 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50011 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50016 IF(AXMI.GE.XMF+XMSF1) THEN
50020 XL=PYLAMF(XMI2,XMA2,XMB2)
50021 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
50022 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
50023 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50024 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50029 XLAM(LKNT)=XLAM(LKNT-1)
50030 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50031 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50036 IF(AXMI.GE.XMF+XMSF2) THEN
50040 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
50041 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
50042 XL=PYLAMF(XMI2,XMA2,XMB2)
50043 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50044 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50049 XLAM(LKNT)=XLAM(LKNT-1)
50050 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50051 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50056 C...3-BODY DECAY TO Q Q~ GLUINO
50057 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50058 IF(AXMI.GE.XMJ) THEN
50059 RT2I = 1D0/SQRT(2D0)
50060 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
50068 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50069 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50070 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
50076 T3I=SIGN(1D0,EI+1D-6)/2D0
50077 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50078 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50082 CXC(4)=DCONJG(GLIJ)
50086 CXC(8)=-DCONJG(GRIJ)
50088 S12MAX=(AXMI-AXMJ)**2
50089 C...ALL QUARKS BUT T
50090 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50092 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
50093 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50094 IDLAM(LKNT,1)=KSUSY1+21
50097 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50099 XLAM(LKNT)=XLAM(LKNT-1)
50100 IDLAM(LKNT,1)=KSUSY1+21
50106 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50107 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50108 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50110 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50111 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50113 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
50116 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50118 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50119 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50120 IDLAM(LKNT,1)=KSUSY1+21
50127 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50128 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50129 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
50133 T3I=SIGN(1D0,EI+1D-6)/2D0
50134 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50135 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50137 CXC(4)=DCONJG(GLIJ)
50139 CXC(8)=-DCONJG(GRIJ)
50140 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50142 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50143 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50144 IDLAM(LKNT,1)=KSUSY1+21
50147 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50149 XLAM(LKNT)=XLAM(LKNT-1)
50150 IDLAM(LKNT,1)=KSUSY1+21
50158 C...R-violating decay modes (SKANDS).
50159 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
50164 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50165 XLAM(0)=XLAM(0)+XLAM(I)
50167 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50172 C*********************************************************************
50175 C...Calculate decay widths for the charginos (admixtures of
50176 C...charged Wino and charged Higgsino.
50178 C...Input: KCIN = KF code for particle
50179 C...Output: XLAM = widths
50180 C... IDLAM = KF codes for decay particles
50181 C... IKNT = number of decay channels defined
50182 C...AUTHOR: STEPHEN MRENNA
50184 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
50185 C...when CHIENU .NE. 0
50187 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
50189 C...Double precision and integer declarations.
50190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50191 IMPLICIT INTEGER(I-N)
50192 INTEGER PYK,PYCHGE,PYCOMP
50193 C...Parameter statement to help give large particle numbers.
50194 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50195 &KEXCIT=4000000,KDIMEN=5000000)
50197 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50198 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50199 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50200 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50201 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50203 C COMMON/PYINTS/XXM(20)
50205 COMMON/PYINTC/XXC(10),CXC(8)
50206 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50208 C...Local variables
50209 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
50210 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
50212 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50213 &XMZ,XMZ2,AXMJ,AXMI
50214 DOUBLE PRECISION S12MIN,S12MAX
50215 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
50216 DOUBLE PRECISION PYLAMF,XL
50217 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
50218 DOUBLE PRECISION PYX2XH,PYX2XG
50219 DOUBLE PRECISION XLAM(0:400)
50220 INTEGER IDLAM(400,3)
50221 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
50224 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
50225 DOUBLE PRECISION SR2
50226 DOUBLE PRECISION CBETA,SBETA,TANB
50228 DOUBLE PRECISION PYALEM,PI,PYALPS
50229 DOUBLE PRECISION FCOL
50230 INTEGER KF1,KF2,ISF
50231 INTEGER KFNCHI(4),KFCCHI(2)
50233 DOUBLE PRECISION TEMP
50234 EXTERNAL PYGAUS,PYXXZ6
50235 DOUBLE PRECISION PYGAUS,PYXXZ6
50236 DOUBLE PRECISION PREC
50239 DATA ETAH/1D0,1D0,-1D0/
50240 DATA SR2/1.4142136D0/
50241 DATA PI/3.141592654D0/
50243 DATA KFNCHI/1000022,1000023,1000025,1000035/
50244 DATA KFCCHI/1000024,1000037/
50246 C...COUNT THE NUMBER OF DECAY MODES
50254 TANW = SQRT(XW/XW1)
50256 C...1 OR 2 DEPENDING ON CHARGINO TYPE
50258 IF(KFIN.EQ.KFCCHI(2)) IX=2
50276 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50277 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50281 C...GRAVITINO DECAY MODES
50283 IF(IMSS(11).EQ.1) THEN
50286 XMGR=PMAS(PYCOMP(IDG),1)
50288 C COSW=SQRT(1D0-XW)
50289 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50290 IF(AXMI.GT.XMGR+XMW) THEN
50296 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
50297 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
50298 & (1D0-XMW2/XMI2)**4
50300 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
50305 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
50306 & (ABS(UMIXC(IX,2))*SBETA)**2))
50307 & *(1D0-PMAS(37,1)**2/XMI2)**4
50311 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50312 IF(IX.EQ.1) GOTO 170
50317 C...CHI_2+ -> CHI_1+ + Z0
50318 IF(AXMI.GE.AXMJ+XMZ) THEN
50321 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
50322 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
50323 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
50324 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
50325 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50326 GLR=DBLE(OLPP*DCONJG(ORPP))
50327 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50328 IDLAM(LKNT,1)=KFCCHI(1)
50332 C...CHARGED LEPTONS
50333 ELSEIF(AXMI.GE.AXMJ) THEN
50335 S12MAX=(AXMI-AXMJ)**2
50338 EI=KCHG(IABS(IA),1)/3D0
50339 T3I=SIGN(1D0,EI+1D-6)/2D0
50344 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50349 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
50350 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
50351 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
50352 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
50353 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50354 CXC(2)=DCMPLX(0D0,0D0)
50355 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50356 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
50357 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50358 CXC(6)=DCMPLX(0D0,0D0)
50359 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50360 CXC(8)=DCMPLX(0D0,0D0)
50361 IF( XXC(5).LT.AXMI ) THEN
50366 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50368 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50369 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50370 IDLAM(LKNT,1)=KFCCHI(1)
50373 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50375 XLAM(LKNT)=XLAM(LKNT-1)
50376 IDLAM(LKNT,1)=KFCCHI(1)
50380 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50382 XLAM(LKNT)=XLAM(LKNT-1)
50383 IDLAM(LKNT,1)=KFCCHI(1)
50393 EI=KCHG(IABS(IA),1)/3D0
50394 T3I=SIGN(1D0,EI+1D-6)/2D0
50395 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50397 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50398 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50399 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
50400 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50401 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50402 IF( XXC(5).LT.AXMI ) THEN
50407 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
50409 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50410 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50411 IDLAM(LKNT,1)=KFCCHI(1)
50415 XLAM(LKNT)=XLAM(LKNT-1)
50416 IDLAM(LKNT,1)=KFCCHI(1)
50420 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
50421 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50422 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50424 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50426 IF( XXC(5).LT.AXMI ) THEN
50431 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50432 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50433 IDLAM(LKNT,1)=KFCCHI(1)
50442 EI=KCHG(IABS(IA),1)/3D0
50443 T3I=SIGN(1D0,EI+1D-6)/2D0
50444 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50446 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50447 CXC(2)=DCMPLX(0D0,0D0)
50448 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50449 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
50450 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50451 CXC(6)=DCMPLX(0D0,0D0)
50452 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50453 CXC(8)=DCMPLX(0D0,0D0)
50454 IF( XXC(5).LT.AXMI ) THEN
50459 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50461 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50462 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50463 IDLAM(LKNT,1)=KFCCHI(1)
50466 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50468 XLAM(LKNT)=XLAM(LKNT-1)
50469 IDLAM(LKNT,1)=KFCCHI(1)
50474 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50475 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50476 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50478 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50480 IF( XXC(5).LT.AXMI ) THEN
50485 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50486 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50487 IDLAM(LKNT,1)=KFCCHI(1)
50496 EI=KCHG(IABS(IA),1)/3D0
50497 T3I=SIGN(1D0,EI+1D-6)/2D0
50498 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50500 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50501 CXC(2)=DCMPLX(0D0,0D0)
50502 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50503 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
50504 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50505 CXC(6)=DCMPLX(0D0,0D0)
50506 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50507 CXC(8)=DCMPLX(0D0,0D0)
50508 IF( XXC(5).LT.AXMI ) THEN
50513 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50515 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50516 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50517 IDLAM(LKNT,1)=KFCCHI(1)
50520 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50522 XLAM(LKNT)=XLAM(LKNT-1)
50523 IDLAM(LKNT,1)=KFCCHI(1)
50531 C...CHI_2+ -> CHI_1+ + H0_K
50539 XMH=PMAS(ITH(IH),1)
50541 C...NO 3-BODY OPTION
50542 IF(AXMI.GE.AXMJ+XMH) THEN
50544 XL=PYLAMF(XMI2,XMJ2,XMH2)
50545 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
50546 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
50547 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
50548 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
50550 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50551 GLR=DBLE(OLPP*DCONJG(ORPP))
50552 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50553 IDLAM(LKNT,1)=KFCCHI(1)
50554 IDLAM(LKNT,2)=ITH(IH)
50559 C...CHI1 JUMPS TO HERE
50562 C...CHI+_I -> CHI0_J + W+
50567 IF(AXMI.GE.AXMJ+XMW) THEN
50570 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
50572 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
50573 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
50574 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
50575 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
50576 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50577 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50578 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50579 IDLAM(LKNT,1)=KFNCHI(IJ)
50583 ELSEIF(AXMI.GE.AXMJ) THEN
50585 S12MAX=(AXMI-AXMJ)**2
50587 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
50589 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
50590 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
50591 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
50592 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
50593 CXC(5)=DCMPLX(0D0,0D0)
50594 CXC(7)=DCMPLX(0D0,0D0)
50598 T3I=SIGN(1D0,EI+1D-6)/2D0
50600 T3J=SIGN(1D0,EJ+1D-6)/2D0
50601 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
50602 & TANW+ZMIXC(IJ,2)*T3J)/SR2
50603 CXC(4)=-DCONJG(UMIXC(IX,1))*(
50604 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
50605 CXC(6)=DCMPLX(0D0,0D0)
50606 CXC(8)=DCMPLX(0D0,0D0)
50611 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50612 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50615 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50616 IF(XXC(5).LT.AXMI) THEN
50618 ELSEIF(XXC(6).LT.AXMI) THEN
50623 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
50624 C...--> 1/(16PI)/M**3*(AEM/XW)**2
50625 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50627 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50628 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
50629 IDLAM(LKNT,1)=KFNCHI(IJ)
50632 C...ONLY DECAY CHI+1 -> E+ NU_E
50633 IF( IMSS(12).NE. 0 ) GOTO 260
50634 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50636 XLAM(LKNT)=XLAM(LKNT-1)
50637 IDLAM(LKNT,1)=KFNCHI(IJ)
50642 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
50644 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50645 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50647 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50649 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50650 IF(XXC(5).LT.AXMI) THEN
50652 ELSEIF(XXC(6).LT.AXMI) THEN
50657 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50658 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
50659 IDLAM(LKNT,1)=KFNCHI(IJ)
50664 C...NOW, DO THE QUARKS
50669 T3I=SIGN(1D0,EI+1D-6)/2D0
50671 T3J=SIGN(1D0,EJ+1D-6)/2D0
50672 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
50673 & TANW+ZMIXC(IJ,2)*T3J)
50674 CXC(4)=-DCONJG(UMIXC(IX,1))*(
50675 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
50676 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50677 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50678 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
50679 IF(XXC(5).LT.AXMI) THEN
50682 IF(XXC(6).LT.AXMI) THEN
50687 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50689 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50690 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50691 IDLAM(LKNT,1)=KFNCHI(IJ)
50694 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50696 XLAM(LKNT)=XLAM(LKNT-1)
50697 IDLAM(LKNT,1)=KFNCHI(IJ)
50706 C...CHI+_I -> CHI0_J + H+
50712 IF(AXMI.GE.AXMJ+XMHP) THEN
50714 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
50715 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
50716 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
50717 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
50719 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50720 GLR=DBLE(OLPP*DCONJG(ORPP))
50721 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
50722 IDLAM(LKNT,1)=KFNCHI(IJ)
50730 C...2-BODY DECAYS TO FERMION SFERMION
50732 IF(J.GE.7.AND.J.LE.10) GOTO 240
50733 IF(MOD(J,2).EQ.0) THEN
50739 XMSF1=PMAS(PYCOMP(KF1),1)
50740 XMSF2=PMAS(PYCOMP(KF2),1)
50749 IF(MOD(J,2).EQ.0) THEN
50752 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
50753 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
50759 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
50761 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
50766 IF(AXMI.GE.XMF+XMSF1) THEN
50770 XL=PYLAMF(XMI2,XMA2,XMB2)
50771 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
50772 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
50773 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50774 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50776 IF(MOD(J,2).EQ.0) THEN
50786 IF(AXMI.GE.XMF+XMSF2) THEN
50790 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
50791 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
50792 XL=PYLAMF(XMI2,XMA2,XMB2)
50793 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50794 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50796 IF(MOD(J,2).EQ.0) THEN
50806 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
50807 C...A 2-BODY -- 2-BODY CHAIN
50808 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50809 IF(AXMI.GE.XMJ) THEN
50812 S12MAX=(AXMI-AXMJ)**2
50817 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50818 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50821 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50823 CXC(1)=DCMPLX(0D0,0D0)
50824 CXC(3)=DCMPLX(0D0,0D0)
50825 CXC(5)=DCMPLX(0D0,0D0)
50826 CXC(7)=DCMPLX(0D0,0D0)
50827 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50828 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50829 CXC(6)=DCMPLX(0D0,0D0)
50830 CXC(8)=DCMPLX(0D0,0D0)
50831 IF(XXC(5).LT.AXMI) THEN
50833 ELSEIF(XXC(6).LT.AXMI) THEN
50838 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
50839 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50841 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
50842 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50843 IDLAM(LKNT,1)=KSUSY1+21
50846 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50848 XLAM(LKNT)=XLAM(LKNT-1)
50849 IDLAM(LKNT,1)=KSUSY1+21
50857 C...R-violating decay modes (SKANDS).
50858 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
50863 XLAM(0)=XLAM(0)+XLAM(I)
50864 IF(XLAM(I).LT.0D0) THEN
50865 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
50866 & (IDLAM(I,J),J=1,3)
50870 IF(XLAM(0).EQ.0D0) THEN
50872 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
50873 WRITE(MSTU(11),*) LKNT
50874 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
50880 C*********************************************************************
50883 C...Used in the calculation of inoi -> inoj + f + ~f.
50887 C...Double precision and integer declarations.
50888 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50889 IMPLICIT INTEGER(I-N)
50890 INTEGER PYK,PYCHGE,PYCOMP
50891 C...Parameter statement to help give large particle numbers.
50892 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50893 &KEXCIT=4000000,KDIMEN=5000000)
50895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50896 C COMMON/PYINTS/XXM(20)
50898 COMMON/PYINTC/XXC(10),CXC(8)
50899 SAVE /PYDAT1/,/PYINTC/
50901 C...Local variables.
50902 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
50903 DOUBLE PRECISION PYXXZ6,X
50904 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
50905 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
50906 DOUBLE PRECISION SIJ
50907 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
50908 DOUBLE PRECISION OL2
50909 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
50912 C...Statement functions.
50913 C...Integral from x to y of (t-a)(b-t) dt.
50914 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
50915 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
50916 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
50917 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
50918 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
50919 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
50920 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
50921 C...Integral from x to y of (t-a)/(b-t) dt.
50922 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
50923 C...Integral from x to y of 1/(t-a) dt.
50924 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
50932 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
50933 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
50934 &( (X-XM22-S)**2 -4D0*XM22*S ) )
50936 S23MIN=(S23AVE-S23DEL)
50937 S23MAX=(S23AVE+S23DEL)
50954 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
50955 SIJ=2D0*XXC(2)*XXC(4)*S13
50956 IF(XMV.LE.1000D0) THEN
50957 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
50958 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
50959 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
50960 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
50961 IF(XXC(5).LE.10000D0) THEN
50962 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
50963 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
50964 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
50965 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
50966 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
50967 & *(S13-XMV**2)/WPROP2
50972 IF(XXC(6).LE.10000D0) THEN
50973 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
50974 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
50975 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
50976 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
50977 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
50978 & *(S13-XMV**2)/WPROP2
50987 IF(XXC(5).LE.10000D0) THEN
50988 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
50989 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
50990 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
50991 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
50995 IF(XXC(6).LE.10000D0) THEN
50996 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
50997 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
50998 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
50999 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
51004 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
51006 IF(PYXXZ6.LT.0D0) THEN
51007 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
51008 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
51009 WRITE(MSTU(11),*) (XXc(I),I=5,8)
51010 WRITE(MSTU(11),*) (XXc(I),I=9,12)
51011 WRITE(MSTU(11),*) (XXc(I),I=13,16)
51012 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
51013 WRITE(MSTU(11),*) S23MIN,S23MAX
51021 C*********************************************************************
51024 C...Calculates chi0_i -> chi0_j + gamma.
51026 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
51028 C...Double precision and integer declarations.
51029 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51030 IMPLICIT INTEGER(I-N)
51031 INTEGER PYK,PYCHGE,PYCOMP
51033 C...Local variables.
51034 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
51035 DOUBLE PRECISION F1,F2
51037 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
51038 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
51039 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
51040 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
51045 C*********************************************************************
51048 C...Calculates the decay rate for ino -> ino + gauge boson.
51050 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
51052 C...Double precision and integer declarations.
51053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51054 IMPLICIT INTEGER(I-N)
51055 INTEGER PYK,PYCHGE,PYCOMP
51057 C...Local variables.
51058 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
51059 DOUBLE PRECISION XL,PYLAMF,C1
51060 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
51066 XL=PYLAMF(XMI2,XMJ2,XMV2)
51067 PYX2XG=C1/8D0/XMI3*SQRT(XL)
51068 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
51069 &12D0*GLR*XM1*XM2*XMV2)
51074 C*********************************************************************
51077 C...Calculates the decay rate for ino -> ino + H.
51079 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
51081 C...Double precision and integer declarations.
51082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51083 IMPLICIT INTEGER(I-N)
51084 INTEGER PYK,PYCHGE,PYCOMP
51086 C...Local variables.
51087 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
51088 DOUBLE PRECISION XL,PYLAMF,C1
51089 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
51095 XL=PYLAMF(XMI2,XMJ2,XMV2)
51096 PYX2XH=C1/8D0/XMI3*SQRT(XL)
51097 &*(GX2*(XMI2+XMJ2-XMV2)+
51103 C*********************************************************************
51106 C...Calculates the non-standard decay modes of the Higgs boson.
51108 C...Author: Stephen Mrenna
51109 C...Last Update: April 2001
51110 C......Allow complex values for Z,U, and V
51112 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
51114 C...Double precision and integer declarations.
51115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51116 IMPLICIT INTEGER(I-N)
51117 INTEGER PYK,PYCHGE,PYCOMP
51118 C...Parameter statement to help give large particle numbers.
51119 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51120 &KEXCIT=4000000,KDIMEN=5000000)
51122 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51123 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51125 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51126 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51127 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51128 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
51130 C...Local variables.
51131 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51132 COMPLEX*16 QIJ,RIJ,F21K,F12K
51134 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
51135 DOUBLE PRECISION XMI2,XMI3,XMJ2
51136 DOUBLE PRECISION PYLAMF,XL,CF,EI
51138 DOUBLE PRECISION TANW,XW,AEM,C1,AS
51139 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
51140 DOUBLE PRECISION XLAM(0:400)
51141 INTEGER IDLAM(400,3)
51142 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
51144 INTEGER KFNCHI(4),KFCCHI(2)
51145 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
51146 DOUBLE PRECISION SR2
51147 DOUBLE PRECISION BETA,ALFA
51148 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
51149 DOUBLE PRECISION PYALEM
51150 DOUBLE PRECISION AL,AR,ALR
51151 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
51152 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
51153 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
51154 DATA ITH/25,35,36,37/
51155 DATA ETAH/1D0,1D0,-1D0/
51156 DATA SR2/1.4142136D0/
51157 DATA KFNCHI/1000022,1000023,1000025,1000035/
51158 DATA KFCCHI/1000024,1000037/
51160 C...COUNT THE NUMBER OF DECAY MODES
51167 TANW = SQRT(XW/(1D0-XW))
51170 C...1 - 4 DEPENDING ON Higgs species.
51172 IF(KFIN.EQ.ITH(2)) IH=2
51173 IF(KFIN.EQ.ITH(3)) IH=3
51174 IF(KFIN.EQ.ITH(4)) IH=4
51197 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51202 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51203 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51208 IF(IH.EQ.4) GOTO 220
51210 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51211 C...H0_K -> CHI0_I + CHI0_J
51224 IF(AXMI.GE.AXMJ+AXMK) THEN
51226 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
51227 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
51228 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
51229 & ZMIXC(IJ,3)*ZMIXC(IK,1))
51230 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
51231 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
51232 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
51233 & ZMIXC(IJ,4)*ZMIXC(IK,1))
51234 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
51235 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
51236 C...SIGN OF MASSES I,J
51238 GX2=ABS(F12K)**2+ABS(F21K)**2
51239 GLR=DBLE(F12K*DCONJG(F21K))
51240 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
51241 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
51242 IDLAM(LKNT,1)=KFNCHI(IJ)
51243 IDLAM(LKNT,2)=KFNCHI(IK)
51249 C...H0_K -> CHI+_I CHI-_J
51256 IF(AXMI.GE.AXMJ+AXMK) THEN
51258 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
51259 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
51260 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
51261 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
51262 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51263 GLR=DBLE(OLPP*DCONJG(ORPP))
51265 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
51266 IDLAM(LKNT,1)=KFCCHI(IJ)
51267 IDLAM(LKNT,2)=-KFCCHI(IK)
51273 C...HIGGS TO SFERMION SFERMION
51275 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
51277 XMJL=PMAS(PYCOMP(IJ),1)
51278 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
51279 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
51282 XL=PYLAMF(XMI2,XMJ2,XMJ2)
51289 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
51290 & XMF**2/XMW*SINA/CBETA
51291 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
51292 & XMF**2/XMW*SINA/CBETA
51294 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
51296 ELSEIF(IFL.EQ.15) THEN
51297 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
51303 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
51304 & XMF**2/XMW*COSA/SBETA
51305 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
51306 & XMF**2/XMW*COSA/SBETA
51308 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
51315 ELSEIF(IH.EQ.2) THEN
51317 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
51318 & XMF**2/XMW*COSA/CBETA
51319 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
51320 & XMF**2/XMW*COSA/CBETA
51322 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
51324 ELSEIF(IFL.EQ.15) THEN
51325 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
51331 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
51332 & XMF**2/XMW*SINA/SBETA
51333 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
51334 & XMF**2/XMW*SINA/SBETA
51336 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
51343 ELSEIF(IH.EQ.3) THEN
51349 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
51350 ELSEIF(IFL.EQ.15) THEN
51351 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
51355 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
51359 IF(IH.EQ.3) GOTO 180
51363 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
51370 IF(AXMI.GE.2D0*XMJ) THEN
51372 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51374 & +2D0*GHLR*ALR)**2
51380 IF(AXMI.GE.2D0*XMJR) THEN
51384 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
51387 XL=PYLAMF(XMI2,XMJ2,XMJ2)
51388 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51390 & +2D0*GHLR*ALR)**2
51391 IDLAM(LKNT,1)=IJ+KSUSY1
51392 IDLAM(LKNT,2)=-(IJ+KSUSY1)
51397 IF(AXMI.GE.XMJL+XMJR) THEN
51399 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
51400 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
51401 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
51404 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
51405 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51406 & (GHLL*AL+GHRR*AR)**2
51408 IDLAM(LKNT,2)=-(IJ+KSUSY1)
51412 IDLAM(LKNT,2)=IJ+KSUSY1
51414 XLAM(LKNT)=XLAM(LKNT-1)
51424 C...H+ -> CHI+_I + CHI0_J
51432 IF(AXMI.GE.AXMJ+AXMK) THEN
51434 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
51435 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
51436 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
51437 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
51438 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51439 GLR=DBLE(OLPP*DCONJG(ORPP))
51440 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
51441 IDLAM(LKNT,1)=KFNCHI(IJ)
51442 IDLAM(LKNT,2)=KFCCHI(IK)
51448 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
51449 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
51455 XM1=PMAS(PYCOMP(KSUSY1+6),1)
51456 XM2=PMAS(PYCOMP(KSUSY1+5),1)
51457 IF(XMI.GE.XM1+XM2) THEN
51458 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51460 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51461 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
51462 IDLAM(LKNT,1)=KSUSY1+6
51463 IDLAM(LKNT,2)=-(KSUSY1+5)
51468 XM1=PMAS(PYCOMP(KSUSY2+6),1)
51469 XM2=PMAS(PYCOMP(KSUSY1+5),1)
51470 IF(XMI.GE.XM1+XM2) THEN
51471 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51473 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51474 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
51475 IDLAM(LKNT,1)=KSUSY2+6
51476 IDLAM(LKNT,2)=-(KSUSY1+5)
51481 XM1=PMAS(PYCOMP(KSUSY1+6),1)
51482 XM2=PMAS(PYCOMP(KSUSY2+5),1)
51483 IF(XMI.GE.XM1+XM2) THEN
51484 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51486 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51487 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
51488 IDLAM(LKNT,1)=KSUSY1+6
51489 IDLAM(LKNT,2)=-(KSUSY2+5)
51494 XM1=PMAS(PYCOMP(KSUSY2+6),1)
51495 XM2=PMAS(PYCOMP(KSUSY2+5),1)
51496 IF(XMI.GE.XM1+XM2) THEN
51497 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51499 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51500 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
51501 IDLAM(LKNT,1)=KSUSY2+6
51502 IDLAM(LKNT,2)=-(KSUSY2+5)
51507 GL=-XMW/SR2*SIN(2D0*BETA)
51509 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
51510 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
51511 IF(XMI.GE.XM1+XM2) THEN
51512 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51514 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
51515 IDLAM(LKNT,1)=-(KSUSY1+IJ)
51516 IDLAM(LKNT,2)=KSUSY1+IJ+1
51524 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
51525 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
51526 IF(XMI.GE.XM1+XM2) THEN
51527 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51529 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
51530 IDLAM(LKNT,1)=-(KSUSY1+IJ)
51531 IDLAM(LKNT,2)=KSUSY1+IJ+1
51536 C...H+ -> TAU1 NUTAUL
51537 XM1=PMAS(PYCOMP(KSUSY1+15),1)
51538 XM2=PMAS(PYCOMP(KSUSY1+16),1)
51539 IF(XMI.GE.XM1+XM2) THEN
51540 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51542 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
51543 IDLAM(LKNT,1)=-(KSUSY1+15)
51544 IDLAM(LKNT,2)= KSUSY1+16
51548 C...H+ -> TAU2 NUTAUL
51549 XM1=PMAS(PYCOMP(KSUSY2+15),1)
51550 XM2=PMAS(PYCOMP(KSUSY1+16),1)
51551 IF(XMI.GE.XM1+XM2) THEN
51552 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51554 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
51555 IDLAM(LKNT,1)=-(KSUSY2+15)
51556 IDLAM(LKNT,2)= KSUSY1+16
51564 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
51565 XLAM(0)=XLAM(0)+XLAM(I)
51567 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51572 C*********************************************************************
51575 C...Calculates the decay rate for a Higgs to an ino pair.
51577 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
51579 C...Double precision and integer declarations.
51580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51581 IMPLICIT INTEGER(I-N)
51582 INTEGER PYK,PYCHGE,PYCOMP
51584 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51587 C...Local variables.
51588 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
51589 DOUBLE PRECISION XL,PYLAMF,C1
51590 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
51596 XL=PYLAMF(XMI2,XMJ2,XMK2)
51597 PYH2XX=C1/4D0/XMI3*SQRT(XL)
51598 &*(GX2*(XMI2-XMJ2-XMK2)-
51600 IF(PYH2XX.LT.0D0) THEN
51601 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
51602 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
51609 C*********************************************************************
51612 C...Integration by adaptive Gaussian quadrature.
51613 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
51615 FUNCTION PYGAUS(F, A, B, EPS)
51617 C...Double precision and integer declarations.
51618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51619 IMPLICIT INTEGER(I-N)
51620 INTEGER PYK,PYCHGE,PYCOMP
51622 C...Local declarations.
51624 DOUBLE PRECISION F,W(12), X(12)
51625 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
51626 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
51627 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
51628 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
51629 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
51630 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
51631 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
51632 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
51633 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
51634 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
51635 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
51636 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
51638 C...The Gaussian quadrature algorithm.
51640 IF(B .EQ. A) GOTO 140
51641 CONST = 5D-3 / ABS(B-A)
51652 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
51657 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
51660 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
51662 IF(BB .NE. B) GOTO 100
51665 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
51667 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
51676 C*********************************************************************
51679 C...Integration by adaptive Gaussian quadrature.
51680 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
51681 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
51683 FUNCTION PYGAU2(F, A, B, EPS)
51685 C...Double precision and integer declarations.
51686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51687 IMPLICIT INTEGER(I-N)
51688 INTEGER PYK,PYCHGE,PYCOMP
51690 C...Local declarations.
51692 DOUBLE PRECISION F,W(12), X(12)
51693 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
51694 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
51695 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
51696 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
51697 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
51698 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
51699 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
51700 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
51701 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
51702 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
51703 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
51704 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
51706 C...The Gaussian quadrature algorithm.
51708 IF(B .EQ. A) GOTO 140
51709 CONST = 5D-3 / ABS(B-A)
51720 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
51725 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
51728 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
51730 IF(BB .NE. B) GOTO 100
51733 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
51735 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
51744 C*********************************************************************
51747 C...Simpson formula for an integral.
51749 FUNCTION PYSIMP(Y,X0,X1,N)
51751 C...Double precision and integer declarations.
51752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51753 IMPLICIT INTEGER(I-N)
51754 INTEGER PYK,PYCHGE,PYCOMP
51756 C...Local variables.
51757 DOUBLE PRECISION Y,X0,X1,H,S
51763 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
51770 C*********************************************************************
51773 C...The standard lambda function.
51775 FUNCTION PYLAMF(X,Y,Z)
51777 C...Double precision and integer declarations.
51778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51779 IMPLICIT INTEGER(I-N)
51780 INTEGER PYK,PYCHGE,PYCOMP
51782 C...Local variables.
51783 DOUBLE PRECISION PYLAMF,X,Y,Z
51785 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
51786 IF(PYLAMF.LT.0D0) PYLAMF=0D0
51791 C*********************************************************************
51794 C...Generates 3-body decays of gauginos.
51796 SUBROUTINE PYTBDY(IDIN)
51798 C...Double precision and integer declarations.
51799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51800 IMPLICIT INTEGER(I-N)
51801 INTEGER PYK,PYCHGE,PYCOMP
51802 C...Parameter statement to help give large particle numbers.
51803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51804 &KEXCIT=4000000,KDIMEN=5000000)
51806 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51807 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51808 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51809 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
51810 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51811 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51812 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51813 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
51814 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
51816 C...Local variables.
51817 DOUBLE PRECISION XM(5)
51818 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
51819 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
51820 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
51821 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
51822 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
51823 DOUBLE PRECISION CPHI1,SPHI1
51824 DOUBLE PRECISION S23DEL,EPS
51825 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
51826 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
51827 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
51829 DATA INOID/22,23,25,35/
51840 S12MIN=(XM(1)+XM(2))**2
51841 S12MAX=(XM(5)-XM(3))**2
51842 YJACO1=S12MAX-S12MIN
51844 C...Initialize some parameters
51853 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
51854 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
51856 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
51857 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
51858 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
51859 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
51864 EI=KCHG(IABS(IA),1)/3D0
51865 T3I=SIGN(1D0,EI+1D-6)/2D0
51866 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
51868 ELSEIF(IZID1*IZID2.NE.0) THEN
51870 GMMZ=PMAS(23,1)*PMAS(23,2)
51872 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
51873 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
51875 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
51876 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
51878 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
51880 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
51882 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
51883 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
51884 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
51885 XM1M2=SMZ(IZID1)*SMZ(IZID2)
51886 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51888 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51890 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
51892 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
51894 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
51895 IF(IZID1.NE.0) THEN
51896 XM1M2=SMZ(IZID1)*SMW(IWID2)
51900 XM1M2=SMZ(IZID2)*SMW(IWID1)
51903 RT2I = 1D0/SQRT(2D0)
51905 GMMZ=PMAS(24,1)*PMAS(24,2)
51907 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
51908 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
51911 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
51913 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
51914 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
51915 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
51916 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
51918 T3J=SIGN(1D0,EJ+1D-6)/2D0
51919 QRLS=DCMPLX(0D0,0D0)
51925 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
51926 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
51927 IF(MOD(IA,2).EQ.0) THEN
51928 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
51929 & TANW+ZMIXC(IZID2,2)*T3I)
51930 QLRT=-DCONJG(UMIXC(IZID1,1))*(
51931 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
51933 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
51934 & TANW+ZMIXC(IZID2,2)*T3J)
51935 QLRT=-DCONJG(UMIXC(IZID1,1))*(
51936 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
51938 ELSEIF(IWID1*IWID2.NE.0) THEN
51941 XM1M2=SMW(IWID1)*SMW(IWID2)
51943 GMMZ=PMAS(23,1)*PMAS(23,2)
51945 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
51946 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
51947 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
51948 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
51950 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
51951 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
51952 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
51953 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
51954 QRLS=-DCMPLX(EI/XW1)*ORPP
51955 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51956 QRRS=-DCMPLX(EI/XW1)*OLPP
51957 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51958 IF(MOD(IA,2).EQ.0) THEN
51959 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
51960 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
51962 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
51963 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
51965 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
51972 IF(ISKIP.NE.0) THEN
51975 S12=S12MIN+YJACO1*(KT-1)/99
51976 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
51977 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
51978 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
51979 & -(2D0*XM(1)*XM(2))**2
51980 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
51981 & -(2D0*XM(3)*XM(5))**2
51984 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
51986 S23MIN=S23AVE-S23DEL
51987 S23MAX=S23AVE+S23DEL
51988 YJACO2=S23MAX-S23MIN
51991 S23=S23MIN+YJACO2*(KS-1)/99
51994 WU2 = (UH-ZM12)*(UH-ZM22)
51995 WT2 = (TH-ZM12)*(TH-ZM22)
51997 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
51998 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
51999 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
52000 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
52001 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
52002 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
52003 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
52004 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
52005 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
52006 IF(WT0.GT.WTMAX) WTMAX=WT0
52016 BX=S12MIN+0.5D0*YJACO1
52019 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
52027 C...SOLVE FOR F1 AND F2
52028 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
52029 &-(2D0*XM(1)*XM(2))**2
52030 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
52031 &-(2D0*XM(3)*XM(5))**2
52034 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
52036 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
52037 &-(2D0*XM(1)*XM(2))**2
52038 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
52039 &-(2D0*XM(3)*XM(5))**2
52042 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
52045 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
52046 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
52052 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
52053 & -(2D0*XM(1)*XM(2))**2
52054 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
52055 & -(2D0*XM(3)*XM(5))**2
52058 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
52065 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
52066 & -(2D0*XM(1)*XM(2))**2
52067 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
52068 & -(2D0*XM(3)*XM(5))**2
52071 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
52076 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
52086 180 S12=S12MIN+PYR(0)*YJACO1
52089 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
52090 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
52091 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
52092 &-(2D0*XM(1)*XM(2))**2
52093 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
52094 &-(2D0*XM(3)*XM(5))**2
52097 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
52099 S23MIN=S23AVE-S23DEL
52100 S23MAX=S23AVE+S23DEL
52101 YJACO2=S23MAX-S23MIN
52102 S23=S23MIN+PYR(0)*YJACO2
52104 C...CHECK THE SAMPLING
52105 IF(IKNT.GT.100) THEN
52106 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
52109 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
52111 IF(ISKIP.EQ.0) GOTO 190
52117 WU2 = (UH-ZM12)*(UH-ZM22)
52118 WT2 = (TH-ZM12)*(TH-ZM22)
52120 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
52121 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
52123 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
52124 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
52125 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
52126 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
52127 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
52128 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
52129 c &/DCMPLX(TH-XML2)
52130 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
52131 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
52132 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
52133 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
52134 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
52135 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
52137 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
52138 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
52140 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
52141 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
52143 P1=SQRT(D1*D1-XM(1)**2)
52144 P2=SQRT(D2*D2-XM(2)**2)
52145 P3=SQRT(D3*D3-XM(3)**2)
52146 CTHE1=2D0*PYR(0)-1D0
52147 ANG1=2D0*PYR(0)*PARU(1)
52151 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
52153 P(N+1,1)=P1*STHE1*CPHI1
52154 P(N+1,2)=P1*STHE1*SPHI1
52159 ANG3=2D0*PYR(0)*PARU(1)
52162 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
52164 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
52166 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
52167 &+P3*STHE3*SPHI3*SPHI1
52168 &+P3*CTHE3*STHE1*CPHI1
52169 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
52170 &-P3*STHE3*SPHI3*CPHI1
52171 &+P3*CTHE3*STHE1*SPHI1
52172 P(N+3,3)=P3*STHE3*CPHI3*STHE1
52177 P(N+2,I)=-P(N+1,I)-P(N+3,I)
52184 C*********************************************************************
52187 C...Finds the s-hat dependent eigenvalues of the inverse propagator
52188 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
52189 C...phase space generation.
52191 SUBROUTINE PYTECM(S1,S2)
52193 C...Double precision and integer declarations.
52194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52195 IMPLICIT INTEGER(I-N)
52196 INTEGER PYK,PYCHGE,PYCOMP
52197 C...Parameter statement to help give large particle numbers.
52198 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52199 &KEXCIT=4000000,KDIMEN=5000000)
52201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52203 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52204 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
52205 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
52207 C...Local variables.
52208 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
52209 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
52210 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
52213 SH=PMAS(PYCOMP(KTECHN+113),1)**2
52216 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
52217 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
52218 QUPD=2D0*RTCM(2)-1D0
52220 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
52221 FAR=SQRT(AEM/ALPRHT)
52227 AR(2,2) = SH-PMAS(23,1)**2
52228 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
52229 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
52249 CALL PYWIDT(23,SH,WDTP,WDTE)
52250 AT(2,2) = WDTP(0)*SHR
52251 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
52252 AT(3,3) = WDTP(0)*SHR
52253 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
52254 AT(4,4) = WDTP(0)*SHR
52256 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
52258 WI(I)=SQRT(ABS(SH-WR(I)))
52261 R1=MIN(WR(1),WR(2),WR(3),WR(4))
52266 IF(ABS(WR(I)-R1).LT.1D-6) THEN
52270 IF(WR(I).LE.R2) THEN
52280 C*********************************************************************
52283 C...Finds eigenvalues of a general complex matrix
52285 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
52286 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
52287 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
52288 C OF A COMPLEX GENERAL MATRIX.
52292 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
52293 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52294 C DIMENSION STATEMENT.
52296 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
52298 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
52299 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
52301 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
52302 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
52303 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
52307 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52308 C RESPECTIVELY, OF THE EIGENVALUES.
52310 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
52311 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
52313 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
52314 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
52315 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
52317 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
52319 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52320 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52322 C THIS VERSION DATED AUGUST 1983.
52325 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
52327 INTEGER N,NM,IS1,IS2,IERR,MATZ
52328 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
52329 X FV1(4),FV2(4),FV3(4)
52330 IF (N .LE. NM) GOTO 100
52334 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
52335 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
52336 IF (MATZ .NE. 0) GOTO 110
52337 C .......... FIND EIGENVALUES ONLY ..........
52338 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
52340 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
52341 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
52342 IF (IERR .NE. 0) GOTO 120
52343 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
52347 C*********************************************************************
52350 C...Auxiliary to PYEICG.
52352 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
52353 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
52355 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
52356 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
52357 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
52359 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
52360 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
52364 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
52365 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52366 C DIMENSION STATEMENT.
52368 C N IS THE ORDER OF THE MATRIX.
52370 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
52371 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
52372 C SET LOW=1, IGH=N.
52374 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
52375 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
52376 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
52377 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
52378 C THE REDUCTION BY CORTH, IF PERFORMED.
52382 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
52383 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
52384 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
52385 C EIGENVECTORS IS TO BE PERFORMED.
52387 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52388 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
52389 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
52390 C FOR INDICES IERR+1,...,N.
52393 C ZERO FOR NORMAL RETURN,
52394 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
52395 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
52397 C CALLS PYCDIV FOR COMPLEX DIVISION.
52398 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
52399 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
52401 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52402 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52404 C THIS VERSION DATED AUGUST 1983.
52407 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
52409 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
52410 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
52411 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
52415 IF (LOW .EQ. IGH) GOTO 130
52416 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
52421 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
52422 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
52423 YR = HR(I,I-1) / NORM
52424 YI = HI(I,I-1) / NORM
52429 SI = YR * HI(I,J) - YI * HR(I,J)
52430 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
52435 SI = YR * HI(J,I) + YI * HR(J,I)
52436 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
52441 C .......... STORE ROOTS ISOLATED BY CBAL ..........
52442 130 DO 140 I = 1, N
52443 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
52452 C .......... SEARCH FOR NEXT EIGENVALUE ..........
52453 150 IF (EN .LT. LOW) GOTO 320
52456 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
52457 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
52458 160 DO 170 LL = LOW, EN
52460 IF (L .EQ. LOW) GOTO 180
52461 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
52462 X + DABS(HR(L,L)) + DABS(HI(L,L))
52463 TST2 = TST1 + DABS(HR(L,L-1))
52464 IF (TST2 .EQ. TST1) GOTO 180
52466 C .......... FORM SHIFT ..........
52467 180 IF (L .EQ. EN) GOTO 300
52468 IF (ITN .EQ. 0) GOTO 310
52469 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
52472 XR = HR(ENM1,EN) * HR(EN,ENM1)
52473 XI = HI(ENM1,EN) * HR(EN,ENM1)
52474 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
52475 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
52476 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
52477 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
52478 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
52481 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
52485 C .......... FORM EXCEPTIONAL SHIFT ..........
52486 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
52489 210 DO 220 I = LOW, EN
52490 HR(I,I) = HR(I,I) - SR
52491 HI(I,I) = HI(I,I) - SI
52498 C .......... REDUCE TO TRIANGLE (ROWS) ..........
52504 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
52505 XR = HR(I-1,I-1) / NORM
52507 XI = HI(I-1,I-1) / NORM
52510 HI(I-1,I-1) = 0.0D0
52511 HI(I,I-1) = SR / NORM
52518 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
52519 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
52520 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
52521 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
52527 IF (SI .EQ. 0.0D0) GOTO 250
52528 NORM = PYTHAG(HR(EN,EN),SI)
52529 SR = HR(EN,EN) / NORM
52533 C .......... INVERSE OPERATION (COLUMNS) ..........
52534 250 DO 280 J = LP1, EN
52543 IF (I .EQ. J) GOTO 260
52545 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52546 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52547 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52548 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52553 IF (SI .EQ. 0.0D0) GOTO 160
52558 HR(I,EN) = SR * YR - SI * YI
52559 HI(I,EN) = SR * YI + SI * YR
52563 C .......... A ROOT FOUND ..........
52564 300 WR(EN) = HR(EN,EN) + TR
52565 WI(EN) = HI(EN,EN) + TI
52568 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
52569 C CONVERGED AFTER 30*N ITERATIONS ..........
52574 C*********************************************************************
52577 C...Auxiliary to PYEICG.
52579 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
52580 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
52582 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
52583 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
52584 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
52586 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
52587 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
52588 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
52589 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
52590 C THIS GENERAL MATRIX TO HESSENBERG FORM.
52594 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
52595 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52596 C DIMENSION STATEMENT.
52598 C N IS THE ORDER OF THE MATRIX.
52600 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
52601 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
52602 C SET LOW=1, IGH=N.
52604 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
52605 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
52606 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
52607 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
52608 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
52610 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
52611 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
52612 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
52613 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
52614 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
52615 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
52620 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
52621 C HAVE BEEN DESTROYED.
52623 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52624 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
52625 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
52626 C FOR INDICES IERR+1,...,N.
52628 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
52629 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
52630 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
52631 C THE EIGENVECTORS HAS BEEN FOUND.
52634 C ZERO FOR NORMAL RETURN,
52635 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
52636 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
52638 C CALLS PYCDIV FOR COMPLEX DIVISION.
52639 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
52640 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
52642 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52643 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52645 C THIS VERSION DATED OCTOBER 1989.
52647 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
52648 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
52651 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
52653 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
52654 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
52655 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
52657 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
52661 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
52670 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
52671 C FROM THE INFORMATION LEFT BY CORTH ..........
52672 IEND = IGH - LOW - 1
52673 IF (IEND.LT.0) GOTO 220
52674 IF (IEND.EQ.0) GOTO 170
52675 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
52676 DO 160 II = 1, IEND
52678 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
52679 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
52680 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
52681 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
52684 DO 120 K = IP1, IGH
52685 ORTR(K) = HR(K,I-1)
52686 ORTI(K) = HI(K,I-1)
52694 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
52695 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
52702 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
52703 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
52709 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
52714 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
52715 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
52716 YR = HR(I,I-1) / NORM
52717 YI = HI(I,I-1) / NORM
52722 SI = YR * HI(I,J) - YI * HR(I,J)
52723 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
52728 SI = YR * HI(J,I) + YI * HR(J,I)
52729 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
52733 DO 200 J = LOW, IGH
52734 SI = YR * ZI(J,I) + YI * ZR(J,I)
52735 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
52740 C .......... STORE ROOTS ISOLATED BY CBAL ..........
52741 220 DO 230 I = 1, N
52742 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
52751 C .......... SEARCH FOR NEXT EIGENVALUE ..........
52752 240 IF (EN .LT. LOW) GOTO 430
52755 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
52756 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
52757 250 DO 260 LL = LOW, EN
52759 IF (L .EQ. LOW) GOTO 270
52760 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
52761 X + DABS(HR(L,L)) + DABS(HI(L,L))
52762 TST2 = TST1 + DABS(HR(L,L-1))
52763 IF (TST2 .EQ. TST1) GOTO 270
52765 C .......... FORM SHIFT ..........
52766 270 IF (L .EQ. EN) GOTO 420
52767 IF (ITN .EQ. 0) GOTO 550
52768 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
52771 XR = HR(ENM1,EN) * HR(EN,ENM1)
52772 XI = HI(ENM1,EN) * HR(EN,ENM1)
52773 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
52774 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
52775 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
52776 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
52777 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
52780 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
52784 C .......... FORM EXCEPTIONAL SHIFT ..........
52785 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
52788 300 DO 310 I = LOW, EN
52789 HR(I,I) = HR(I,I) - SR
52790 HI(I,I) = HI(I,I) - SI
52797 C .......... REDUCE TO TRIANGLE (ROWS) ..........
52803 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
52804 XR = HR(I-1,I-1) / NORM
52806 XI = HI(I-1,I-1) / NORM
52809 HI(I-1,I-1) = 0.0D0
52810 HI(I,I-1) = SR / NORM
52817 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
52818 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
52819 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
52820 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
52826 IF (SI .EQ. 0.0D0) GOTO 350
52827 NORM = PYTHAG(HR(EN,EN),SI)
52828 SR = HR(EN,EN) / NORM
52832 IF (EN .EQ. N) GOTO 350
52838 HR(EN,J) = SR * YR + SI * YI
52839 HI(EN,J) = SR * YI - SI * YR
52841 C .......... INVERSE OPERATION (COLUMNS) ..........
52842 350 DO 390 J = LP1, EN
52851 IF (I .EQ. J) GOTO 360
52853 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52854 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52855 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52856 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52859 DO 380 I = LOW, IGH
52864 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52865 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52866 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52867 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52872 IF (SI .EQ. 0.0D0) GOTO 250
52877 HR(I,EN) = SR * YR - SI * YI
52878 HI(I,EN) = SR * YI + SI * YR
52881 DO 410 I = LOW, IGH
52884 ZR(I,EN) = SR * YR - SI * YI
52885 ZI(I,EN) = SR * YI + SI * YR
52889 C .......... A ROOT FOUND ..........
52890 420 HR(EN,EN) = HR(EN,EN) + TR
52892 HI(EN,EN) = HI(EN,EN) + TI
52896 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
52897 C VECTORS OF UPPER TRIANGULAR FORM ..........
52903 TR = DABS(HR(I,J)) + DABS(HI(I,J))
52904 IF (TR .GT. NORM) NORM = TR
52907 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
52908 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
52916 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
52917 DO 490 II = 1, ENM1
52924 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
52925 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
52930 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
52933 460 YR = 0.01D0 * YR
52935 IF (TST2 .GT. TST1) GOTO 460
52937 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
52938 C .......... OVERFLOW CONTROL ..........
52939 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
52940 IF (TR .EQ. 0.0D0) GOTO 490
52942 TST2 = TST1 + 1.0D0/TST1
52943 IF (TST2 .GT. TST1) GOTO 490
52945 HR(J,EN) = HR(J,EN)/TR
52946 HI(J,EN) = HI(J,EN)/TR
52952 C .......... END BACKSUBSTITUTION ..........
52953 C .......... VECTORS OF ISOLATED ROOTS ..........
52955 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
52963 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
52964 C VECTORS OF ORIGINAL FULL MATRIX.
52965 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
52970 DO 540 I = LOW, IGH
52975 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
52976 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
52984 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
52985 C CONVERGED AFTER 30*N ITERATIONS ..........
52990 C*********************************************************************
52993 C...Auxiliary to PYCMQR
52995 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
52998 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
53000 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
53001 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
53003 S = DABS(BR) + DABS(BI)
53008 S = BRS**2 + BIS**2
53009 CR = (ARS*BRS + AIS*BIS)/S
53010 CI = (AIS*BRS - ARS*BIS)/S
53014 C*********************************************************************
53017 C...Auxiliary to PYCMQR
53019 C (YR,YI) = COMPLEX DSQRT(XR,XI)
53020 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
53023 SUBROUTINE PYCSRT(XR,XI,YR,YI)
53025 DOUBLE PRECISION XR,XI,YR,YI
53026 DOUBLE PRECISION S,TR,TI,PYTHAG
53030 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
53031 IF (TR .GE. 0.0D0) YR = S
53032 IF (TI .LT. 0.0D0) S = -S
53033 IF (TR .LE. 0.0D0) YI = S
53034 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
53035 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
53039 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
53040 DOUBLE PRECISION A,B
53042 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
53044 DOUBLE PRECISION P,R,S,T,U
53045 P = DMAX1(DABS(A),DABS(B))
53046 IF (P .EQ. 0.0D0) GOTO 110
53047 R = (DMIN1(DABS(A),DABS(B))/P)**2
53050 IF (T .EQ. 4.0D0) GOTO 110
53052 U = 1.0D0 + 2.0D0*S
53060 C*********************************************************************
53063 C...Auxiliary to PYEICG
53065 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
53066 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
53067 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
53068 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
53070 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
53071 C EIGENVALUES WHENEVER POSSIBLE.
53075 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53076 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53077 C DIMENSION STATEMENT.
53079 C N IS THE ORDER OF THE MATRIX.
53081 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53082 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
53086 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53087 C RESPECTIVELY, OF THE BALANCED MATRIX.
53089 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
53090 C ARE EQUAL TO ZERO IF
53091 C (1) I IS GREATER THAN J AND
53092 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
53094 C SCALE CONTAINS INFORMATION DETERMINING THE
53095 C PERMUTATIONS AND SCALING FACTORS USED.
53097 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
53098 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
53099 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
53100 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
53101 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
53102 C = D(J,J) J = LOW,...,IGH
53103 C = P(J) J = IGH+1,...,N.
53104 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
53107 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
53109 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
53110 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
53111 C K,L HAVE BEEN REVERSED.)
53113 C ARITHMETIC IS REAL THROUGHOUT.
53115 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53116 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53118 C THIS VERSION DATED AUGUST 1983.
53121 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
53123 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
53124 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
53125 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
53134 C .......... IN-LINE PROCEDURE FOR ROW AND
53135 C COLUMN EXCHANGE ..........
53137 IF (J .EQ. M) GOTO 130
53157 130 IF(IEXC.EQ.1) GOTO 140
53158 IF(IEXC.EQ.2) GOTO 180
53159 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
53160 C AND PUSH THEM DOWN ..........
53161 140 IF (L .EQ. 1) GOTO 320
53163 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
53164 150 DO 170 JJ = 1, L
53168 IF (I .EQ. J) GOTO 160
53169 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
53178 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
53179 C AND PUSH THEM LEFT ..........
53182 190 DO 210 J = K, L
53185 IF (I .EQ. J) GOTO 200
53186 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
53193 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
53195 220 SCALE(I) = 1.0D0
53196 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
53197 230 NOCONV = .FALSE.
53204 IF (J .EQ. I) GOTO 240
53205 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
53206 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
53208 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
53209 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
53213 250 IF (C .GE. G) GOTO 260
53218 270 IF (C .LT. G) GOTO 280
53222 C .......... NOW BALANCE ..........
53223 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
53225 SCALE(I) = SCALE(I) * F
53229 AR(I,J) = AR(I,J) * G
53230 AI(I,J) = AI(I,J) * G
53234 AR(J,I) = AR(J,I) * F
53235 AI(J,I) = AI(J,I) * F
53240 IF (NOCONV) GOTO 230
53247 C*********************************************************************
53250 C...Auxiliary to PYEICG.
53252 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
53253 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
53254 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
53255 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
53257 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
53258 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
53259 C BALANCED MATRIX DETERMINED BY CBAL.
53263 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53264 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53265 C DIMENSION STATEMENT.
53267 C N IS THE ORDER OF THE MATRIX.
53269 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
53271 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
53272 C AND SCALING FACTORS USED BY CBAL.
53274 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
53276 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53277 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
53278 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
53282 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53283 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
53284 C IN THEIR FIRST M COLUMNS.
53286 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53287 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53289 C THIS VERSION DATED AUGUST 1983.
53292 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
53294 INTEGER I,J,K,M,N,II,NM,IGH,LOW
53295 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
53298 IF (M .EQ. 0) GOTO 150
53299 IF (IGH .EQ. LOW) GOTO 120
53301 DO 110 I = LOW, IGH
53303 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
53304 C IF THE FOREGOING STATEMENT IS REPLACED BY
53305 C S=1.0D0/SCALE(I). ..........
53307 ZR(I,J) = ZR(I,J) * S
53308 ZI(I,J) = ZI(I,J) * S
53312 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
53313 C IGH+1 STEP 1 UNTIL N DO -- ..........
53314 120 DO 140 II = 1, N
53316 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53317 IF (I .LT. LOW) I = LOW - II
53319 IF (K .EQ. I) GOTO 140
53335 C*********************************************************************
53338 C...Auxiliary to PYEICG.
53340 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
53341 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
53342 C BY MARTIN AND WILKINSON.
53343 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
53345 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
53346 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
53347 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
53348 C UNITARY SIMILARITY TRANSFORMATIONS.
53352 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53353 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53354 C DIMENSION STATEMENT.
53356 C N IS THE ORDER OF THE MATRIX.
53358 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53359 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53360 C SET LOW=1, IGH=N.
53362 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53363 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
53367 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53368 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
53369 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
53370 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
53371 C HESSENBERG MATRIX.
53373 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
53374 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
53376 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53378 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53379 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53381 C THIS VERSION DATED AUGUST 1983.
53384 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
53386 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
53387 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
53388 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
53392 IF (LA .LT. KP1) GOTO 210
53399 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
53401 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
53403 IF (SCALE .EQ. 0.0D0) GOTO 200
53405 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
53408 ORTR(I) = AR(I,M-1) / SCALE
53409 ORTI(I) = AI(I,M-1) / SCALE
53410 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
53414 F = PYTHAG(ORTR(M),ORTI(M))
53415 IF (F .EQ. 0.0D0) GOTO 120
53418 ORTR(M) = (1.0D0 + G) * ORTR(M)
53419 ORTI(M) = (1.0D0 + G) * ORTI(M)
53424 C .......... FORM (I-(U*UT)/H) * A ..........
53425 130 DO 160 J = M, N
53428 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
53431 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
53432 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
53439 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
53440 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
53444 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
53448 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
53451 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
53452 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
53459 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
53460 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
53465 ORTR(M) = SCALE * ORTR(M)
53466 ORTI(M) = SCALE * ORTI(M)
53467 AR(M,M-1) = -G * AR(M,M-1)
53468 AI(M,M-1) = -G * AI(M,M-1)
53474 C*********************************************************************
53477 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
53480 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
53482 INTEGER N,NP,INDX(N)
53484 COMPLEX*16 A(NP,NP)
53485 PARAMETER (TINY=1.0D-20)
53487 REAL*8 AAMAX,VV(6),DUM
53488 COMPLEX*16 SUM,DUMC
53494 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
53496 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
53503 SUM=SUM-A(I,K)*A(K,J)
53511 SUM=SUM-A(I,K)*A(K,J)
53515 IF (DUM.GE.AAMAX) THEN
53530 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
53533 A(I,J)=A(I,J)/A(J,J)
53541 C*********************************************************************
53544 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
53547 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
53549 INTEGER N,NP,INDX(N)
53550 COMPLEX*16 A(NP,NP),B(N)
53561 SUM=SUM-A(I,J)*B(J)
53563 ELSE IF (ABS(SUM).NE.0D0) THEN
53571 SUM=SUM-A(I,J)*B(J)
53578 C***********************************************************************
53581 C...Calculates full and partial widths of resonances.
53582 C....copy of PYWIDT, used for techniparticle widths
53584 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
53586 C...Double precision and integer declarations.
53587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53588 IMPLICIT INTEGER(I-N)
53589 INTEGER PYK,PYCHGE,PYCOMP
53590 C...Parameter statement to help give large particle numbers.
53591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53592 &KEXCIT=4000000,KDIMEN=5000000)
53594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53596 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53597 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
53598 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53599 COMMON/PYINT1/MINT(400),VINT(400)
53600 COMMON/PYINT4/MWID(500),WIDS(500,5)
53601 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53602 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53603 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
53604 &/PYINT4/,/PYMSSM/,/PYTCSM/
53605 C...Local arrays and saved variables.
53606 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
53608 SAVE MOFSV,WIDWSV,WID2SV
53609 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
53611 C...Compressed code and sign; mass.
53618 C...Reset width information.
53626 C...Common electroweak and strong constants.
53629 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
53632 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
53634 RADC=1D0+AS/PARU(1)
53636 IF(KFLA.EQ.23) THEN
53639 XWC=1D0/(16D0*XW*XW1)
53640 FAC=(AEM*XWC/3D0)*SHR
53642 DO 130 I=1,MDCY(KC,3)
53644 IF(MDME(IDC,1).LT.0) GOTO 130
53645 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
53646 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
53647 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
53652 AF=SIGN(1D0,EF+0.1D0)
53655 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
53656 IF(I.EQ.6) WID2=WIDS(6,1)
53657 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
53658 ELSEIF(I.LE.16) THEN
53659 C...Z0 -> l+ + l-, nu + nubar
53661 AF=SIGN(1D0,EF+0.1D0)
53664 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
53666 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
53667 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
53669 WDTP(0)=WDTP(0)+WDTP(I)
53670 IF(MDME(IDC,1).GT.0) THEN
53671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
53673 & WDTE(I,MDME(IDC,1))
53674 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53675 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53680 ELSEIF(KFLA.EQ.24) THEN
53682 FAC=(AEM/(24D0*XW))*SHR
53683 DO 140 I=1,MDCY(KC,3)
53685 IF(MDME(IDC,1).LT.0) GOTO 140
53686 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
53687 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
53688 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
53691 C...W+/- -> q + qbar'
53692 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
53694 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
53695 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
53696 IF(I.GE.13) WID2=WID2*WIDS(7,3)
53698 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
53699 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
53700 IF(I.GE.13) WID2=WID2*WIDS(7,2)
53702 ELSEIF(I.LE.20) THEN
53703 C...W+/- -> l+/- + nu
53706 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
53708 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
53711 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
53712 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
53713 WDTP(0)=WDTP(0)+WDTP(I)
53714 IF(MDME(IDC,1).GT.0) THEN
53715 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53716 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
53717 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53718 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53722 C.....V8 -> quark anti-quark
53723 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
53726 IF(ITCM(2).EQ.0) THEN
53728 ELSEIF(ITCM(2).EQ.1) THEN
53731 DO 150 I=1,MDCY(KC,3)
53733 IF(MDME(IDC,1).LT.0) GOTO 150
53734 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
53736 IF(RM1.GT.0.25D0) GOTO 150
53738 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
53743 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
53744 IF(I.EQ.6) WID2=WIDS(6,1)
53745 WDTP(0)=WDTP(0)+WDTP(I)
53746 IF(MDME(IDC,1).GT.0) THEN
53747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
53749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53758 C*********************************************************************
53761 C...Calculates R-violating decays of sfermions.
53764 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
53766 C...Double precision and integer declarations.
53767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53768 IMPLICIT INTEGER(I-N)
53769 C...Parameter statement to help give large particle numbers.
53770 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53771 &KEXCIT=4000000,KDIMEN=5000000)
53773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53774 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53775 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53776 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53777 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
53778 C...Local variables.
53779 DOUBLE PRECISION XLAM(0:400)
53780 INTEGER IDLAM(400,3), PYCOMP
53781 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
53783 C...IS R-VIOLATION ON ?
53784 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
53785 C...Mass eigenstate counter
53786 ICNT=INT(KFIN/KSUSY1)
53787 C...SM KF code of SUSY particle
53788 KFSM=KFIN-ICNT*KSUSY1
53789 C...Squared Sparticle Mass
53790 SM=PMAS(PYCOMP(KFIN),1)**2
53791 C... Squared mass of top quark
53792 SMT=PMAS(PYCOMP(6),1)**2
53793 C...IS L-VIOLATION ON ?
53794 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
53795 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
53796 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
53802 C...~e,~mu,~tau -> nu_I + lepton-_J
53804 IDLAM(LKNT,1)= 12 +2*(I-1)
53805 IDLAM(LKNT,2)= 11 +2*(J-1)
53808 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53809 IF (IMSS(51).NE.0) XLAM(LKNT) =
53810 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53811 C...KINEMATICS CHECK
53812 IF (XLAM(LKNT).EQ.0D0) THEN
53818 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
53824 IDLAM(LKNT,1)=-12 -2*(I-1)
53825 IDLAM(LKNT,2)= 11 +2*(K-1)
53828 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53829 IF (IMSS(51).NE.0) XLAM(LKNT) =
53830 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53831 C...KINEMATICS CHECK
53832 IF (XLAM(LKNT).EQ.0D0) THEN
53838 C...~e,~mu,~tau -> u_Jbar + d_K
53843 IDLAM(LKNT,1)=-2 -2*(J-1)
53844 IDLAM(LKNT,2)= 1 +2*(K-1)
53847 IF (IMSS(52).NE.0) THEN
53848 C...Use massive top quark
53849 IF (IDLAM(LKNT,1).EQ.-6) THEN
53850 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
53853 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
53854 C...If no top quark, all decay products massless
53856 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53858 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53860 C...KINEMATICS CHECK
53861 IF (XLAM(LKNT).EQ.0D0) THEN
53868 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
53869 C...No right-handed neutrinos
53871 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
53876 C...~nu_J -> lepton+_I + lepton-_K
53878 IDLAM(LKNT,1)=-11 -2*(I-1)
53879 IDLAM(LKNT,2)= 11 +2*(K-1)
53882 RM2=RVLAM(I,J,K)**2 * SM
53883 IF (IMSS(51).NE.0) XLAM(LKNT) =
53884 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53885 C...KINEMATICS CHECK
53886 IF (XLAM(LKNT).EQ.0D0) THEN
53892 C...~nu_I -> dbar_J + d_K
53897 IDLAM(LKNT,1)=-1 -2*(J-1)
53898 IDLAM(LKNT,2)= 1 +2*(K-1)
53901 RM2=3*RVLAMP(I,J,K)**2 * SM
53902 IF (IMSS(52).NE.0) XLAM(LKNT) =
53903 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53904 C...KINEMATICS CHECK
53905 IF (XLAM(LKNT).EQ.0D0) THEN
53912 C * SDOWN -> NU(BAR) + D and LEPTON- + U
53913 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
53917 C...~d_J -> nu_Ibar + d_K
53919 IDLAM(LKNT,1)=-12 -2*(I-1)
53920 IDLAM(LKNT,2)= 1 +2*(K-1)
53923 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53924 IF (IMSS(52).NE.0) XLAM(LKNT) =
53925 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53926 C...KINEMATICS CHECK
53927 IF (XLAM(LKNT).EQ.0D0) THEN
53935 C...~d_K -> nu_I + d_J
53937 IDLAM(LKNT,1)= 12 +2*(I-1)
53938 IDLAM(LKNT,2)= 1 +2*(J-1)
53941 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53942 IF (IMSS(52).NE.0) XLAM(LKNT) =
53943 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53944 C...KINEMATICS CHECK
53945 IF (XLAM(LKNT).EQ.0D0) THEN
53948 C...~d_K -> lepton_I- + u_J
53950 IDLAM(LKNT,1)= 11 +2*(I-1)
53951 IDLAM(LKNT,2)= 2 +2*(J-1)
53954 IF (IMSS(52).NE.0) THEN
53955 C...Use massive top quark
53956 IF (IDLAM(LKNT,2).EQ.6) THEN
53957 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
53959 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
53960 C...If no top quark, all decay products massless
53962 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53964 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53966 C...KINEMATICS CHECK
53967 IF (XLAM(LKNT).EQ.0D0) THEN
53974 C * SUP -> LEPTON+ + D
53975 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
53979 C...~u_J -> lepton_I+ + d_K
53981 IDLAM(LKNT,1)=-11 -2*(I-1)
53982 IDLAM(LKNT,2)= 1 +2*(K-1)
53985 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53986 IF (IMSS(52).NE.0) XLAM(LKNT) =
53987 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53988 C...KINEMATICS CHECK
53989 IF (XLAM(LKNT).EQ.0D0) THEN
53996 C...BARYON NUMBER VIOLATING DECAYS
53997 IF (IMSS(53).GE.1) THEN
53998 C * SUP -> DBAR + DBAR
53999 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
54003 C...~u_I -> dbar_J + dbar_K
54005 C...(anti-) symmetry J <-> K.
54007 IDLAM(LKNT,1) = -1 -2*(J-1)
54008 IDLAM(LKNT,2) = -1 -2*(K-1)
54011 RM2 = 2.*(RVLAMB(I,J,K)**2)
54012 & * SFMIX(KFSM,2*ICNT)**2 * SM
54014 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54015 C...KINEMATICS CHECK
54016 IF (XLAM(LKNT).EQ.0D0) THEN
54023 C * SDOWN -> UBAR + DBAR
54024 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
54028 C...LAMB coupling antisymmetric in J and K.
54030 C...~d_K -> ubar_I + dbar_K
54032 IDLAM(LKNT,1)= -2 -2*(I-1)
54033 IDLAM(LKNT,2)= -1 -2*(J-1)
54036 C...Use massive top quark
54037 IF (IDLAM(LKNT,1).EQ.-6) THEN
54038 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
54041 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54042 C...If no top quark, all decay products massless
54044 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54046 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54048 C...KINEMATICS CHECK
54049 IF (XLAM(LKNT).EQ.0D0) THEN
54062 C*********************************************************************
54065 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
54068 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
54070 C...Double precision and integer declarations.
54071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54072 IMPLICIT INTEGER(I-N)
54073 C...Parameter statement to help give large particle numbers.
54074 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54075 &KEXCIT=4000000,KDIMEN=5000000)
54077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54079 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54080 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54081 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54082 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54083 C...Local variables.
54084 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54086 DOUBLE PRECISION XLAM(0:400)
54087 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
54088 INTEGER IDLAM(400,3), PYCOMP
54090 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
54092 C...R-VIOLATING DECAYS
54093 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54095 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
54096 C...WHICH NEUTRALINO ?
54098 IF (KFSM.EQ.23) NCHI=2
54099 IF (KFSM.EQ.25) NCHI=3
54100 IF (KFSM.EQ.35) NCHI=4
54101 C...SIGN OF MASS (Opposite convention as HERWIG)
54103 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
54105 C...Useful parameters for the calculation of the A and B constants.
54106 WMASS = PMAS(PYCOMP(24),1)
54107 ECHG = 2*SQRT(PARU(103)*PARU(1))
54108 COSB=1/(SQRT(1+RMSS(5)**2))
54109 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
54110 COSW=SQRT(1-PARU(102))
54111 SINW=SQRT(PARU(102))
54112 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
54113 C...Run quark masses to neutralino mass squared (for Higgs-type
54115 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
54117 RMQ(I)=PYMRUN(I,SQMCHI)
54119 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
54121 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
54122 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
54123 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
54124 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
54126 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
54127 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
54128 C2=ECHG*ZPMIX(NCHI,1)
54129 C3=GW*ZPMIX(NCHI,2)/COSW
54133 C x=1-2 : Select A or B constant (1:A ; 2:B)
54134 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54135 C 11-16:e,nu_e,mu,...)
54136 C z=1-2 : Mass eigenstate number
54137 C...CALCULATE COUPLINGS
54139 CMS=PMAS(PYCOMP(I),1)
54140 C...Intermediate sleptons
54141 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
54142 & *(C2-C3*SINW**2))
54143 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
54144 & *(C2-C3*SINW**2))
54145 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
54147 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
54149 C...Inermediate sneutrinos
54151 AB(2,I+1,1)=5D-1*C3
54154 C...Inermediate sdown
54157 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
54158 & *ED*(C2-C3*SINW**2))
54159 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
54160 & *ED*(C2-C3*SINW**2))
54161 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
54162 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
54163 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
54164 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
54165 C...Inermediate sup
54168 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
54169 & *EU*(C2-C3*SINW**2))
54170 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
54171 & *EU*(C2-C3*SINW**2))
54172 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
54173 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
54174 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
54175 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
54178 IF (IMSS(51).GE.1) THEN
54179 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
54180 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
54181 C...STEP IN I,J,K USING SINGLE COUNTER
54183 C...LAMBDA COUPLING ASYM IN I,J
54184 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
54186 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54187 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
54188 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
54190 C...Set coupling, and decay product masses on/off
54191 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54192 & ,MOD(ISC,3)+1)**2
54194 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
54196 C...Resonance KF codes (1=I,2=J,3=K)
54197 KFR(1)=-IDLAM(LKNT,1)
54198 KFR(2)=-IDLAM(LKNT,2)
54199 KFR(3)=-IDLAM(LKNT,3)
54200 C...Calculate width.
54201 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54202 & IDLAM(LKNT,3),XLAM(LKNT))
54203 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54204 C...Charge conjugate mode.
54206 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54207 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54208 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54209 XLAM(LKNT)=XLAM(LKNT-1)
54210 C...KINEMATICS CHECK
54211 IF (XLAM(LKNT).EQ.0D0) THEN
54218 IF (IMSS(52).GE.1) THEN
54219 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
54220 C * CHI0 -> NUBAR_I + DBAR_J + D_K
54223 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54224 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54225 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54227 C...Set coupling, and decay product masses on/off
54228 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54229 & ,MOD(ISC,3)+1)**2
54231 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
54233 C...Resonance KF codes (1=I,2=J,3=K)
54234 KFR(1)=-IDLAM(LKNT,1)
54235 KFR(2)=-IDLAM(LKNT,2)
54236 KFR(3)=-IDLAM(LKNT,3)
54237 C...Calculate width.
54238 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54240 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54241 C...Charge conjugate mode.
54243 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54244 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54245 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54246 XLAM(LKNT)=XLAM(LKNT-1)
54247 C...KINEMATICS CHECK
54248 IF (XLAM(LKNT).EQ.0D0) THEN
54252 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
54254 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54255 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54256 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54258 C...Set coupling, and decay product masses on/off
54259 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54260 & ,MOD(ISC,3)+1)**2
54262 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
54263 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
54264 C...Resonance KF codes (1=I,2=J,3=K)
54265 KFR(1)=-IDLAM(LKNT,1)
54266 KFR(2)=-IDLAM(LKNT,2)
54267 KFR(3)=-IDLAM(LKNT,3)
54268 C...Calculate width.
54269 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54271 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54272 C...Charge conjugate mode.
54274 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54275 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54276 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54277 XLAM(LKNT)=XLAM(LKNT-1)
54278 C...KINEMATICS CHECK
54279 IF (XLAM(LKNT).EQ.0D0) THEN
54285 IF (IMSS(53).GE.1) THEN
54286 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
54287 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
54289 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
54290 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
54292 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
54293 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54294 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54296 C...Set coupling, and decay product masses on/off
54297 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
54298 & +1,MOD(ISC,3)+1)**2
54300 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
54301 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
54302 C...Resonance KF codes (1=I,2=J,3=K)
54303 KFR(1) = IDLAM(LKNT,1)
54304 KFR(2) = IDLAM(LKNT,2)
54305 KFR(3) = IDLAM(LKNT,3)
54306 C...Calculate width.
54307 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54308 & IDLAM(LKNT,3),XLAM(LKNT))
54309 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54310 C...Charge conjugate mode.
54312 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54313 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54314 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54315 XLAM(LKNT)=XLAM(LKNT-1)
54316 C...KINEMATICS CHECK
54317 IF (XLAM(LKNT).EQ.0D0) THEN
54329 C*********************************************************************
54332 C...Calculates R-violating chargino decay widths.
54335 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
54337 C...Double precision and integer declarations.
54338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54339 IMPLICIT INTEGER(I-N)
54340 C...Parameter statement to help give large particle numbers.
54341 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54342 &KEXCIT=4000000,KDIMEN=5000000)
54344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54346 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54347 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54348 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54349 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54350 C...Local variables.
54351 DOUBLE PRECISION XLAM(0:400)
54352 INTEGER IDLAM(400,3), PYCOMP
54353 C...Information from main routine to PYRVGW
54354 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54356 C...Auxiliary variables needed for BV (RV Gauge STOre)
54357 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
54359 C...Running quark masses
54360 DOUBLE PRECISION RMQ(6)
54361 C...Decay product masses on/off
54363 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
54367 C...IF R-VIOLATION ON.
54368 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54370 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
54371 C...WHICH CHARGINO ?
54373 IF (KFSM.EQ.37) NCHI = 2
54375 C...Useful parameters for calculating the A and B constants.
54376 C...SIGN OF MASS (Opposite convention as HERWIG)
54378 IF (SMW(NCHI).LT.0D0) ISM = -1
54379 WMASS = PMAS(PYCOMP(24),1)
54380 COSB = 1/(SQRT(1+RMSS(5)**2))
54381 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
54382 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
54383 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
54384 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
54387 C...Running masses at Q^2=MCHI^2.
54388 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
54390 RMQ(I)=PYMRUN(I,SQMCHI)
54393 C... AB(x,y,z) coefficients:
54394 C x=1-2 : A or B coefficient (1:A ; 2:B)
54395 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54396 C 11-16:e,nu_e,mu,...)
54397 C z=1-2 : Mass eigenstate number
54399 C...Intermediate sleptons
54402 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
54404 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
54406 C...Intermediate sneutrinos
54407 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
54409 AB(2,I+1,1) = ISM*C3
54411 C...Intermediate sdown
54413 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
54414 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
54415 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
54416 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
54417 C...Intermediate sup
54419 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
54420 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
54421 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
54422 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
54425 C...LLE TYPE R-VIOLATION
54426 IF (IMSS(51).GE.1) THEN
54427 C...LOOP OVER DECAY MODES
54430 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
54431 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
54433 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
54434 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
54435 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
54437 C...Set coupling, and decay product masses on/off
54438 RVLAMC = GW2 * 5D-1 *
54439 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54442 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
54443 C...Resonance KF codes (1=I,2=J,3=K).
54446 KFR(3) = -IDLAM(LKNT,3)+1
54447 C...Calculate width.
54448 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54449 & IDLAM(LKNT,3),XLAM(LKNT))
54450 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54451 C...KINEMATICS CHECK
54452 IF (XLAM(LKNT).EQ.0D0) THEN
54456 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
54457 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
54459 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
54460 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
54461 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
54463 C...Set coupling, and decay product masses on/off
54464 RVLAMC = GW2 * 5D-1 *
54465 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54466 C...I,J SYMMETRY => FACTOR 2
54469 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
54470 C...Resonance KF codes (1=I,2=J,3=K)
54471 KFR(1)=IDLAM(LKNT,1)-1
54472 KFR(2)=IDLAM(LKNT,2)-1
54474 C...Calculate width.
54475 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54476 & IDLAM(LKNT,3),XLAM(LKNT))
54477 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54478 C...KINEMATICS CHECK
54479 IF (XLAM(LKNT).EQ.0D0) THEN
54484 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
54486 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54487 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
54488 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
54490 C...Set coupling, and decay product masses on/off
54491 RVLAMC = GW2 * 5D-1 *
54492 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54493 C...I,J SYMMETRY => FACTOR 2
54496 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
54497 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
54498 C...Resonance KF codes (1=I,2=J,3=K)
54499 KFR(1) =-IDLAM(LKNT,1)+1
54500 KFR(2) =-IDLAM(LKNT,2)+1
54502 C...Calculate width.
54503 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54504 & IDLAM(LKNT,3),XLAM(LKNT))
54505 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54506 C...KINEMATICS CHECK
54507 IF (XLAM(LKNT).EQ.0D0) THEN
54514 C...LQD TYPE R-VIOLATION
54515 IF (IMSS(52).GE.1) THEN
54516 C...LOOP OVER DECAY MODES
54519 C...CHI+ -> NUBAR_I + DBAR_J + U_K
54521 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54522 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54523 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
54525 C...Set coupling, and decay product masses on/off
54526 RVLAMC = 3. * GW2 * 5D-1 *
54527 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54529 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
54531 C...Resonance KF codes (1=I,2=J,3=K)
54534 KFR(3)=-IDLAM(LKNT,3)+1
54535 C...Calculate width.
54536 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54538 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54539 C...KINEMATICS CHECK
54540 IF (XLAM(LKNT).EQ.0D0) THEN
54544 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
54546 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54547 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54548 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
54550 C...Set coupling, and decay product masses on/off
54551 RVLAMC = 3. * GW2 * 5D-1 *
54552 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54554 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
54555 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
54556 C...Resonance KF codes (1=I,2=J,3=K)
54559 KFR(3)=-IDLAM(LKNT,3)+1
54560 C...Calculate width.
54561 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54563 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54564 C...KINEMATICS CHECK
54565 IF (XLAM(LKNT).EQ.0D0) THEN
54569 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
54571 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54572 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54573 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54575 C...Set coupling, and decay product masses on/off
54576 RVLAMC = 3. * GW2 * 5D-1 *
54577 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54579 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
54580 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
54581 C...Resonance KF codes (1=I,2=J,3=K)
54582 KFR(1)=-IDLAM(LKNT,1)+1
54583 KFR(2)=-IDLAM(LKNT,2)+1
54585 C...Calculate width.
54586 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54588 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54589 C...KINEMATICS CHECK
54590 IF (XLAM(LKNT).EQ.0D0) THEN
54594 C * CHI+ -> NU_I + U_J + DBAR_K.
54596 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
54597 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
54598 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54600 C...Set coupling, and decay product masses on/off
54602 RVLAMC = 3. * GW2 * 5D-1 *
54603 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54604 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
54606 C...Resonance KF codes (1=I,2=J,3=K)
54607 KFR(1)=IDLAM(LKNT,1)-1
54608 KFR(2)=IDLAM(LKNT,2)-1
54610 C...Calculate width.
54611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54613 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54614 C...KINEMATICS CHECK
54615 IF (XLAM(LKNT).EQ.0D0) THEN
54622 C...UDD TYPE R-VIOLATION
54623 C...These decays need special treatment since more than one BV coupling
54624 C...contributes (with interference). Consider e.g. (symbolically)
54625 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
54626 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
54627 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
54628 C...The problem is that a single call to PYRVGW would evaluate all
54629 C...these terms and sum them, but without the different couplings. The
54630 C...way out is to call PYRVGW three times, once for the first line, once
54631 C...for the second line, and then once for all the lines (it is
54632 C...impossible to get just the last line out) without multiplying by
54633 C...couplings. The last line is then obtained as the result of the third
54634 C...call minus the results of the two first calls. Each term is then
54635 C...multiplied by its respective coupling before the whole thing is
54636 C...summed up in XLAM.
54637 C...Note that with three interfering resonances, this procedure becomes
54638 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
54640 IF (IMSS(53).GE.1) THEN
54641 C...LOOP OVER DECAY MODES
54644 C...CHI+ -> U_I + U_J + D_K
54645 C...Decay mode I<->J symmetric.
54646 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
54648 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
54649 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
54650 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54652 C...Set coupling, and decay product masses on/off
54653 RVLAMC= 6. * GW2 * 5D-1
54654 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
54656 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
54658 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
54661 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
54662 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
54663 C...Resonance KF codes (1=I,2=J,3=K)
54664 KFR(1) = -IDLAM(LKNT,1)+1
54667 C...Calculate width.
54668 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54669 & IDLAM(LKNT,3),XRESI)
54670 C...Resonance KF codes (1=I,2=J,3=K)
54672 KFR(2) = -IDLAM(LKNT,2)+1
54674 C...Calculate width.
54675 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54676 & IDLAM(LKNT,3),XRESJ)
54677 C...Resonance KF codes (1=I,2=J,3=K)
54678 KFR(1) = -IDLAM(LKNT,1)+1
54679 KFR(2) = -IDLAM(LKNT,2)+1
54681 C...Calculate width.
54682 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54683 & IDLAM(LKNT,3),XRESIJ)
54684 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
54685 XRESIJ = XRESIJ-XRESI-XRESJ
54689 C...CALCULATE TOTAL WIDTH
54690 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
54691 & + RVLJIK*RVLIJK * XRESIJ
54692 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54693 C...KINEMATICS CHECK
54694 IF (XLAM(LKNT).EQ.0D0) THEN
54698 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
54699 C...Symmetry I<->J<->K.
54700 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
54701 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
54703 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
54704 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54705 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54707 C...Set coupling, and decay product masses on/off
54708 RVLAMC = 6. * GW2 * 5D-1
54709 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
54711 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
54713 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
54716 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
54717 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
54718 C...Collect symmetry factors
54719 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
54720 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
54721 & RVLAMC = 5D-1 * RVLAMC
54722 C...Resonance KF codes (1=I,2=J,3=K)
54723 KFR(1) = IDLAM(LKNT,1)-1
54726 C...Calculate width.
54727 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54728 & IDLAM(LKNT,3),XRESI)
54729 C...Resonance KF codes (1=I,2=J,3=K)
54731 KFR(2) = IDLAM(LKNT,2)-1
54733 C...Calculate width.
54734 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54735 & IDLAM(LKNT,3),XRESJ)
54736 C...Resonance KF codes (1=I,2=J,3=K)
54739 KFR(3) = IDLAM(LKNT,3)-1
54740 C...Calculate width.
54741 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54742 & IDLAM(LKNT,3),XRESK)
54743 C...Resonance KF codes (1=I,2=J,3=K)
54744 KFR(1) = IDLAM(LKNT,1)-1
54745 KFR(2) = IDLAM(LKNT,2)-1
54747 C...Calculate width.
54748 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54749 & IDLAM(LKNT,3),XRESIJ)
54750 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
54751 XRESIJ = XRESI+XRESJ-XRESIJ
54755 C...Resonance KF codes (1=I,2=J,3=K)
54757 KFR(2) = IDLAM(LKNT,2)-1
54758 KFR(3) = IDLAM(LKNT,3)-1
54759 C...Calculate width.
54760 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54761 & IDLAM(LKNT,3),XRESJK)
54762 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
54763 XRESJK = XRESJ+XRESK-XRESJK
54767 C...Resonance KF codes (1=I,2=J,3=K)
54768 KFR(1) = IDLAM(LKNT,1)-1
54770 KFR(3) = IDLAM(LKNT,3)-1
54771 C...Calculate width.
54772 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54773 & IDLAM(LKNT,3),XRESIK)
54774 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
54775 XRESIK = XRESI+XRESK-XRESIK
54779 C...CALCULATE TOTAL WIDTH
54781 & RVLIJK**2 * XRESI
54782 & + RVLJKI**2 * XRESJ
54783 & + RVLKIJ**2 * XRESK
54784 & + RVLIJK*RVLJKI * XRESIJ
54785 & + RVLIJK*RVLKIJ * XRESIK
54786 & + RVLJKI*RVLKIJ * XRESJK
54787 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
54788 C...KINEMATICS CHECK
54789 IF (XLAM(LKNT).EQ.0D0) THEN
54801 C*********************************************************************
54804 C...Calculates R-violating gluino decay widths.
54805 C...See BV part of PYRVCH for comments about the way the BV decay width
54806 C...is calculated. Same comments apply here.
54809 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
54811 C...Double precision and integer declarations.
54812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54813 IMPLICIT INTEGER(I-N)
54814 C...Parameter statement to help give large particle numbers.
54815 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54816 &KEXCIT=4000000,KDIMEN=5000000)
54818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54820 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54821 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54822 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54823 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54824 C...Local variables.
54825 DOUBLE PRECISION XLAM(0:400)
54826 INTEGER IDLAM(400,3), PYCOMP
54827 C...Information from main routine to PYRVGW
54828 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54830 C...Auxiliary variables needed for BV (RV Gauge STOre)
54831 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
54833 C...Running quark masses
54834 DOUBLE PRECISION RMQ(6)
54835 C...Decay product masses on/off
54837 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
54840 C...IF LQD OR UDD TYPE R-VIOLATION ON.
54841 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
54845 C x=1-2 : Select A or B coupling (1:A ; 2:B)
54846 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54847 C 11-16:e,nu_e,mu,... not used here)
54848 C z=1-2 : Mass eigenstate number
54851 AB(1,I,1) = SFMIX(I,2)
54852 AB(1,I,2) = SFMIX(I,4)
54854 AB(2,I,1) = -SFMIX(I,1)
54855 AB(2,I,2) = -SFMIX(I,3)
54857 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
54859 IF (IMSS(52).GE.1) THEN
54860 C...STEP IN I,J,K USING SINGLE COUNTER
54862 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
54864 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54865 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54866 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54868 C...Set coupling, and decay product masses on/off
54869 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54872 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
54873 C...Resonance KF codes (1=I,2=J,3=K)
54875 KFR(2) = -IDLAM(LKNT,2)
54876 KFR(3) = -IDLAM(LKNT,3)
54877 C...Calculate width.
54878 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54881 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54882 C...Charge conjugate mode.
54884 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
54885 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
54886 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
54887 XLAM(LKNT) = XLAM(LKNT-1)
54888 C...KINEMATICS CHECK
54889 IF (XLAM(LKNT).EQ.0D0) THEN
54893 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
54895 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54896 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54897 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54899 C...Set coupling, and decay product masses on/off
54900 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54901 & **2* 5D-1 * GSTR2
54903 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
54904 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
54905 C...Resonance KF codes (1=I,2=J,3=K)
54907 KFR(2) = -IDLAM(LKNT,2)
54908 KFR(3) = -IDLAM(LKNT,3)
54909 C...Calculate width.
54910 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54912 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54913 C...Charge conjugate mode.
54915 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
54916 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
54917 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
54918 XLAM(LKNT) = XLAM(LKNT-1)
54919 C...KINEMATICS CHECK
54920 IF (XLAM(LKNT).EQ.0D0) THEN
54928 IF (IMSS(53).GE.1) THEN
54929 C...STEP IN I,J,K USING SINGLE COUNTER
54931 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
54932 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
54934 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
54935 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54936 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54938 C...Set coupling, and decay product masses on/off. A factor of 2 for
54939 C...(N_C-1) has been used to cancel a factor 0.5.
54940 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54943 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
54944 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
54945 C...Resonance KF codes (1=I,2=J,3=K)
54946 KFR(1) = IDLAM(LKNT,1)
54949 C...Calculate width.
54950 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54952 C...Resonance KF codes (1=I,2=J,3=K)
54954 KFR(2) = IDLAM(LKNT,2)
54956 C...Calculate width.
54957 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54959 C...Resonance KF codes (1=I,2=J,3=K)
54962 KFR(3) = IDLAM(LKNT,3)
54963 C...Calculate width.
54964 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54966 C...Resonance KF codes (1=I,2=J,3=K)
54967 KFR(1) = IDLAM(LKNT,1)
54968 KFR(2) = IDLAM(LKNT,2)
54970 C...Calculate width.
54971 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54973 C...Calculate interference function. (Factor -1/2 to make up for factor
54975 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
54976 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
54980 C...Resonance KF codes (1=I,2=J,3=K)
54982 KFR(2) = IDLAM(LKNT,2)
54983 KFR(3) = IDLAM(LKNT,3)
54984 C...Calculate width.
54985 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54987 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
54988 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
54992 C...Resonance KF codes (1=I,2=J,3=K)
54993 KFR(1) = IDLAM(LKNT,1)
54995 KFR(3) = IDLAM(LKNT,3)
54996 C...Calculate width.
54997 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54999 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
55000 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
55004 C...Calculate total width (factor 1/2 from 1/(N_C-1))
55005 XLAM(LKNT) = XRESI + XRESJ + XRESK
55006 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
55008 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55009 C...Charge conjugate mode.
55011 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
55012 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
55013 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
55014 XLAM(LKNT) = XLAM(LKNT-1)
55015 C...KINEMATICS CHECK
55016 IF (XLAM(LKNT).EQ.0D0) THEN
55026 C*********************************************************************
55029 C...Auxiliary function to PYRVSF for calculating R-Violating
55030 C...sfermion widths. Though the decay products are most often treated
55031 C...as massless in the calculation, the kinematical boundary of phase
55032 C...space is tested using the true masses.
55033 C...MODE = 1: All decay products massive
55034 C...MODE = 2: Decay product 1 massless
55035 C...MODE = 3: Decay product 2 massless
55036 C...MODE = 4: All decay products massless
55038 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
55040 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55041 IMPLICIT INTEGER (I-N)
55042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55044 SAVE /PYDAT1/,/PYDAT2/
55045 DOUBLE PRECISION SM(3)
55046 INTEGER PYCOMP, KC(3)
55050 SM(1)=PMAS(KC(1),1)**2
55051 SM(2)=PMAS(KC(2),1)**2
55052 SM(3)=PMAS(KC(3),1)**2
55053 C...Kinematics check
55054 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
55058 C...CM momenta squared
55059 IF (MODE.EQ.1) THEN
55060 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
55061 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
55062 ELSE IF (MODE.EQ.2) THEN
55063 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
55064 ELSE IF (MODE.EQ.3) THEN
55065 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
55069 C...Calculate Width
55070 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
55074 C*********************************************************************
55077 C...Generalized Matrix Element for R-Violating 3-body widths.
55079 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
55081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55082 IMPLICIT INTEGER (I-N)
55083 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55084 &KEXCIT=4000000,KDIMEN=5000000)
55085 PARAMETER (EPS=1D-4)
55086 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55087 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55089 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55090 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55091 DOUBLE PRECISION XLIM(3,3)
55092 INTEGER KC(0:3), PYCOMP
55093 LOGICAL DCMASS, DCHECK(6)
55094 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
55098 KC(0) = PYCOMP(KFIN)
55099 KC(1) = PYCOMP(ID1)
55100 KC(2) = PYCOMP(ID2)
55101 KC(3) = PYCOMP(ID3)
55102 RMS(0) = PMAS(KC(0),1)
55103 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
55104 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
55105 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
55106 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
55107 XLIM(1,1)=(RMS(1)+RMS(2))**2
55108 XLIM(1,2)=(RMS(0)-RMS(3))**2
55109 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
55110 XLIM(2,1)=(RMS(2)+RMS(3))**2
55111 XLIM(2,2)=(RMS(0)-RMS(1))**2
55112 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
55113 XLIM(3,1)=(RMS(1)+RMS(3))**2
55114 XLIM(3,2)=(RMS(0)-RMS(2))**2
55115 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
55116 C...Check Phase Space
55117 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
55121 C...INITIALIZE RESONANCE INFORMATION
55124 IRES = 2*(JRES-1)+IMASS
55126 DCHECK(IRES) =.FALSE.
55127 C...NO RIGHT-HANDED NEUTRINOS
55128 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
55129 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
55130 & .KFR(JRES).EQ.0) GOTO 100
55131 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
55132 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
55133 INTRES(IRES,1) = IABS(KFR(JRES))
55134 INTRES(IRES,2) = IMASS
55135 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
55136 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
55140 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
55142 C...RESONANCE CONTRIBUTIONS
55143 C...(Only sum contributions where the resonance is off shell).
55144 C...Store whether diagram on/off in DCHECK.
55145 C...LOOP OVER MASS STATES
55148 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55149 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
55150 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55151 DCHECK(IDR) =.TRUE.
55152 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
55156 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55157 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
55158 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55159 DCHECK(IDR) =.TRUE.
55160 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
55164 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55165 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
55166 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55167 DCHECK(IDR) =.TRUE.
55168 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
55171 C... L-R INTERFERENCES
55172 C... (Only add contributions where both contributing diagrams
55173 C... are non-resonant).
55175 IF (DCHECK(1).AND.DCHECK(2)) THEN
55176 C...Bug corrected 11/12 2001. Skands.
55177 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
55178 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
55179 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
55183 IF (DCHECK(3).AND.DCHECK(4)) THEN
55184 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
55185 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
55186 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
55190 IF (DCHECK(5).AND.DCHECK(6)) THEN
55191 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
55192 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
55193 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
55195 C... TRUE INTERFERENCES
55196 C... (Only add contributions where both contributing diagrams
55197 C... are non-resonant).
55199 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
55204 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55205 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
55206 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55207 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55212 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55213 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
55214 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55215 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55220 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55221 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
55222 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55223 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55231 C*********************************************************************
55234 C...Function to integrate resonance contributions
55236 FUNCTION PYRVI1(ID1,ID2,ID3)
55239 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
55240 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55241 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55242 LOGICAL MFLAG,DCMASS
55243 EXTERNAL PYRVG1,PYGAUS
55244 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55246 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55247 SAVE/PYRVNV/,/PYRVPM/
55248 C...Initialize mass and width information
55254 RESM(1)= RES(IDR,1)
55255 RESW(1)= RES(IDR,2)
55256 C...A->B and B->A for antisparticles
55257 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55258 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55259 C...Integration boundaries and mass flag
55260 LO = (RM(1)+RM(2))**2
55261 HI = (RM(0)-RM(3))**2
55263 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
55267 C*********************************************************************
55270 C...Function to integrate L-R interference contributions
55272 FUNCTION PYRVI2(ID1,ID2,ID3)
55275 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
55276 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55277 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55278 LOGICAL MFLAG,DCMASS
55279 EXTERNAL PYRVG2,PYGAUS
55280 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55282 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55283 SAVE/PYRVNV/,/PYRVPM/
55284 C...Initialize mass and width information
55290 RESM(1)= RES(IDR,1)
55291 RESW(1)= RES(IDR,2)
55292 RESM(2)= RES(IDR+1,1)
55293 RESW(2)= RES(IDR+1,2)
55294 C...A->B and B->A for antisparticles
55295 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55296 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55297 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
55298 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
55299 C...Boundaries and mass flag
55300 LO = (RM(1)+RM(2))**2
55301 HI = (RM(0)-RM(3))**2
55303 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
55307 C*********************************************************************
55310 C...Function to integrate true interference contributions
55312 FUNCTION PYRVI3(ID1,ID2,ID3)
55315 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
55316 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55317 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55318 LOGICAL MFLAG,DCMASS
55319 EXTERNAL PYRVG3,PYGAUS
55320 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55322 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55323 SAVE/PYRVNV/,/PYRVPM/
55324 C...Initialize mass and width information
55330 RESM(1)= RES(IDR,1)
55331 RESW(1)= RES(IDR,2)
55332 RESM(2)= RES(IDR2,1)
55333 RESW(2)= RES(IDR2,2)
55334 C...A -> B and B -> A for antisparticles
55335 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55336 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55337 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
55338 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
55339 C...Boundaries and mass flag
55340 LO = (RM(1)+RM(2))**2
55341 HI = (RM(0)-RM(3))**2
55343 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
55347 C*********************************************************************
55350 C...Integrand for resonance contributions
55355 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55356 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
55357 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
55360 RVR = PYRVR(X,RESM(1),RESW(1))
55361 C1 = 2D0*SQRT(MAX(0D0,X))
55362 IF (.NOT.MFLAG) THEN
55364 E3 = (RM(0)**2-X)/C1
55366 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
55368 E2 = (X-RM(1)**2+RM(2)**2)/C1
55369 E3 = (RM(0)**2-X-RM(3)**2)/C1
55370 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55371 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55372 DELTAY = 4D0*SR1*SR2
55373 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
55374 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
55375 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
55380 C*********************************************************************
55383 C...Integrand for L-R interference contributions
55388 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55389 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
55390 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
55393 C1 = 2D0*SQRT(MAX(0D0,X))
55394 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
55395 IF (.NOT.MFLAG) THEN
55397 E3 = (RM(0)**2-X)/C1
55399 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
55401 E2 = (X-RM(1)**2+RM(2)**2)/C1
55402 E3 = (RM(0)**2-X-RM(3)**2)/C1
55403 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55404 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55405 DELTAY = 4D0*SR1*SR2
55406 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
55407 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
55408 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
55413 C*********************************************************************
55416 C...Function to do Y integration over true interference contributions
55421 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55422 C...Second Dalitz variable for PYRVG4
55424 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
55425 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
55426 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
55428 EXTERNAL PYGAU2,PYRVG4
55429 SAVE/PYRVPM/,/PYG2DX/
55431 C1=2D0*SQRT(MAX(1D-9,X))
55433 IF (.NOT.MFLAG) THEN
55435 E3 = (RM(0)**2-X)/C1
55439 E2 = (X-RM(1)**2+RM(2)**2)/C1
55440 E3 = (RM(0)**2-X-RM(3)**2)/C1
55442 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55443 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55444 YMIN = SQ1-(SR1+SR2)**2
55445 YMAX = SQ1-(SR1-SR2)**2
55447 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
55451 C*********************************************************************
55454 C...Integrand for true intereference contributions
55459 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55461 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
55463 SAVE /PYRVPM/,/PYG2DX/
55465 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
55466 IF (.NOT.MFLAG) THEN
55467 PYRVG4 = RVS*B(1)*B(2)*X*Y
55469 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
55470 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
55471 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
55472 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
55477 C*********************************************************************
55480 C...Breit-Wigner for resonance contributions
55482 FUNCTION PYRVR(Mab2,RM,RW)
55485 DOUBLE PRECISION Mab2,RM,RW,PYRVR
55486 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
55490 C*********************************************************************
55493 C...Interference function
55495 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
55498 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
55499 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
55504 C*********************************************************************
55507 C...Stores one parton/particle in commonblock PYJETS.
55509 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
55511 C...Double precision and integer declarations.
55512 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55513 IMPLICIT INTEGER(I-N)
55514 INTEGER PYK,PYCHGE,PYCOMP
55516 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55517 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55518 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55519 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55521 C...Standard checks.
55523 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55524 IPA=MAX(1,IABS(IP))
55525 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
55526 &'(PY1ENT:) writing outside PYJETS memory')
55528 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
55530 C...Find mass. Reset K, P and V vectors.
55532 IF(MSTU(10).EQ.1) PM=P(IPA,5)
55533 IF(MSTU(10).GE.2) PM=PYMASS(KF)
55540 C...Store parton/particle in K and P vectors.
55542 IF(IP.LT.0) K(IPA,1)=2
55545 P(IPA,4)=MAX(PE,PM)
55546 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
55547 P(IPA,1)=PA*SIN(THE)*COS(PHI)
55548 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
55549 P(IPA,3)=PA*COS(THE)
55551 C...Set N. Optionally fragment/decay.
55553 IF(IP.EQ.0) CALL PYEXEC
55558 C*********************************************************************
55561 C...Stores two partons/particles in their CM frame,
55562 C...with the first along the +z axis.
55564 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
55566 C...Double precision and integer declarations.
55567 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55568 IMPLICIT INTEGER(I-N)
55569 INTEGER PYK,PYCHGE,PYCOMP
55571 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55574 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55576 C...Standard checks.
55578 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55579 IPA=MAX(1,IABS(IP))
55580 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
55581 &'(PY2ENT:) writing outside PYJETS memory')
55584 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
55585 &'(PY2ENT:) unknown flavour code')
55587 C...Find masses. Reset K, P and V vectors.
55589 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55590 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55592 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55593 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55602 C...Check flavours.
55603 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55604 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55605 IF(MSTU(19).EQ.1) THEN
55608 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
55609 & '(PY2ENT:) unphysical flavour combination')
55614 C...Store partons/particles in K vectors for normal case.
55617 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
55620 C...Store partons in K vectors for parton shower evolution.
55624 K(IPA,4)=MSTU(5)*(IPA+1)
55626 K(IPA+1,4)=MSTU(5)*IPA
55627 K(IPA+1,5)=K(IPA+1,4)
55630 C...Check kinematics and store partons/particles in P vectors.
55631 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
55632 &'(PY2ENT:) energy smaller than sum of masses')
55633 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
55636 P(IPA,4)=SQRT(PM1**2+PA**2)
55639 P(IPA+1,4)=SQRT(PM2**2+PA**2)
55642 C...Set N. Optionally fragment/decay.
55644 IF(IP.EQ.0) CALL PYEXEC
55649 C*********************************************************************
55652 C...Stores three partons or particles in their CM frame,
55653 C...with the first along the +z axis and the third in the (x,z)
55654 C...plane with x > 0.
55656 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
55658 C...Double precision and integer declarations.
55659 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55660 IMPLICIT INTEGER(I-N)
55661 INTEGER PYK,PYCHGE,PYCOMP
55663 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55665 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55666 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55668 C...Standard checks.
55670 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55671 IPA=MAX(1,IABS(IP))
55672 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
55673 &'(PY3ENT:) writing outside PYJETS memory')
55677 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
55678 &'(PY3ENT:) unknown flavour code')
55680 C...Find masses. Reset K, P and V vectors.
55682 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55683 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55685 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55686 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55688 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
55689 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
55698 C...Check flavours.
55699 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55700 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55701 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
55702 IF(MSTU(19).EQ.1) THEN
55704 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
55705 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
55706 & KQ1+KQ3.EQ.4)) THEN
55708 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
55714 C...Store partons/particles in K vectors for normal case.
55717 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
55719 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
55722 C...Store partons in K vectors for parton shower evolution.
55728 IF(KQ1.EQ.-1) KCS=5
55729 K(IPA,KCS)=MSTU(5)*(IPA+1)
55730 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
55731 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
55732 K(IPA+1,9-KCS)=MSTU(5)*IPA
55733 K(IPA+2,KCS)=MSTU(5)*IPA
55734 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
55737 C...Check kinematics.
55739 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
55740 &0.5D0*X3*PECM.LE.PM3) MKERR=1
55741 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
55742 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
55743 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
55744 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
55745 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
55746 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
55747 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
55748 IF(MKERR.NE.0) CALL PYERRM(13,
55749 &'(PY3ENT:) unphysical kinematical variable setup')
55751 C...Store partons/particles in P vectors.
55753 P(IPA,4)=SQRT(PA1**2+PM1**2)
55755 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
55756 P(IPA+2,3)=PA3*CTHE3
55757 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
55759 P(IPA+1,1)=-P(IPA+2,1)
55760 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
55761 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
55764 C...Set N. Optionally fragment/decay.
55766 IF(IP.EQ.0) CALL PYEXEC
55771 C*********************************************************************
55774 C...Stores four partons or particles in their CM frame, with
55775 C...the first along the +z axis, the last in the xz plane with x > 0
55776 C...and the second having y < 0 and y > 0 with equal probability.
55778 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
55780 C...Double precision and integer declarations.
55781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55782 IMPLICIT INTEGER(I-N)
55783 INTEGER PYK,PYCHGE,PYCOMP
55785 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55786 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55787 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55788 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55790 C...Standard checks.
55792 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55793 IPA=MAX(1,IABS(IP))
55794 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
55795 &'(PY4ENT:) writing outside PYJETS momory')
55800 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
55801 &'(PY4ENT:) unknown flavour code')
55803 C...Find masses. Reset K, P and V vectors.
55805 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55806 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55808 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55809 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55811 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
55812 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
55814 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
55815 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
55824 C...Check flavours.
55825 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55826 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55827 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
55828 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
55829 IF(MSTU(19).EQ.1) THEN
55831 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
55832 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
55833 & KQ1+KQ4.EQ.4)) THEN
55834 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
55837 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
55844 C...Store partons/particles in K vectors for normal case.
55847 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
55849 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
55852 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
55855 C...Store partons for parton shower evolution from q-g-g-qbar or
55857 ELSEIF(KQ1+KQ2.NE.0) THEN
55863 IF(KQ1.EQ.-1) KCS=5
55864 K(IPA,KCS)=MSTU(5)*(IPA+1)
55865 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
55866 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
55867 K(IPA+1,9-KCS)=MSTU(5)*IPA
55868 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
55869 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
55870 K(IPA+3,KCS)=MSTU(5)*IPA
55871 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
55873 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
55879 K(IPA,4)=MSTU(5)*(IPA+1)
55881 K(IPA+1,4)=MSTU(5)*IPA
55882 K(IPA+1,5)=K(IPA+1,4)
55883 K(IPA+2,4)=MSTU(5)*(IPA+3)
55884 K(IPA+2,5)=K(IPA+2,4)
55885 K(IPA+3,4)=MSTU(5)*(IPA+2)
55886 K(IPA+3,5)=K(IPA+3,4)
55889 C...Check kinematics.
55891 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
55892 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
55894 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
55895 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
55896 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
55897 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
55898 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
55899 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
55900 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
55901 STHE4=SQRT(1D0-CTHE4**2)
55902 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
55903 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
55904 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
55905 STHE2=SQRT(1D0-CTHE2**2)
55906 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
55907 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
55908 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
55909 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
55910 IF(MKERR.EQ.1) CALL PYERRM(13,
55911 &'(PY4ENT:) unphysical kinematical variable setup')
55913 C...Store partons/particles in P vectors.
55915 P(IPA,4)=SQRT(PA1**2+PM1**2)
55917 P(IPA+3,1)=PA4*STHE4
55918 P(IPA+3,3)=PA4*CTHE4
55919 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
55921 P(IPA+1,1)=PA2*STHE2*CPHI2
55922 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
55923 P(IPA+1,3)=PA2*CTHE2
55924 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
55926 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
55927 P(IPA+2,2)=-P(IPA+1,2)
55928 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
55929 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
55932 C...Set N. Optionally fragment/decay.
55934 IF(IP.EQ.0) CALL PYEXEC
55939 C*********************************************************************
55942 C...An interface from a two-fermion generator to include
55943 C...parton showers and hadronization.
55945 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
55947 C...Double precision and integer declarations.
55948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55949 IMPLICIT INTEGER(I-N)
55950 INTEGER PYK,PYCHGE,PYCOMP
55952 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55954 SAVE /PYJETS/,/PYDAT1/
55956 DIMENSION IJOIN(2),INTAU(2)
55958 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
55964 C...Loop through entries and pick up all final fermions/antifermions.
55968 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55970 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
55971 IF(K(I,2).GT.0) THEN
55975 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
55981 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
55987 C...Check that event is arranged according to conventions.
55988 IF(I1.EQ.0.OR.I2.EQ.0) THEN
55989 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
55992 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
55995 C...Check whether fermion pair is quarks or leptons.
55996 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
55998 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
56001 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
56004 C...Decide whether to allow or not photon radiation in showers.
56006 IF(IRAD.EQ.0) MSTJ(41)=1
56008 C...Do colour joining and parton showers.
56011 IF(IQL12.EQ.1) THEN
56014 CALL PYJOIN(2,IJOIN)
56016 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56017 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56018 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56019 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56022 C...Do fragmentation and decays. Possibly except tau decay.
56026 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56040 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56048 C*********************************************************************
56051 C...An interface from a four-fermion generator to include
56052 C...parton showers and hadronization.
56054 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
56056 C...Double precision and integer declarations.
56057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56058 IMPLICIT INTEGER(I-N)
56059 INTEGER PYK,PYCHGE,PYCOMP
56061 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56063 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56064 COMMON/PYINT1/MINT(400),VINT(400)
56065 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
56067 DIMENSION IJOIN(2),INTAU(4)
56069 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56075 C...Loop through entries and pick up all final fermions/antifermions.
56081 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56083 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
56084 IF(K(I,2).GT.0) THEN
56087 ELSEIF(I3.EQ.0) THEN
56090 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
56095 ELSEIF(I4.EQ.0) THEN
56098 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
56104 C...Check that event is arranged according to conventions.
56105 IF(I3.EQ.0.OR.I4.EQ.0) THEN
56106 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
56108 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
56109 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
56112 C...Check which fermion pairs are quarks and which leptons.
56113 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
56115 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
56118 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
56120 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56122 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
56125 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
56128 C...Decide whether to allow or not photon radiation in showers.
56130 IF(IRAD.EQ.0) MSTJ(41)=1
56132 C...Decide on dipole pairing.
56137 IF(IQL12.EQ.IQL34) THEN
56140 DELTA=ATOTSQ-A1SQ-A2SQ
56141 IF(ISTRAT.EQ.1) THEN
56142 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
56143 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
56144 ELSEIF(ISTRAT.EQ.2) THEN
56145 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
56146 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
56148 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
56154 C...If colour reconnection then bookkeep W+W- or Z0Z0
56155 C...and copy q qbar q qbar consecutively.
56156 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
56165 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
56169 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
56183 P(N+1,J)=P(IP1,J)+P(IP2,J)
56184 P(N+2,J)=P(IP3,J)+P(IP4,J)
56196 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56198 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56204 C...Remove original q qbar q qbar and update counters.
56205 K(IP1,1)=K(IP1,1)+10
56206 K(IP2,1)=K(IP2,1)+10
56207 K(IP3,1)=K(IP3,1)+10
56208 K(IP4,1)=K(IP4,1)+10
56219 C...Do colour joinings and parton showers.
56220 IF(IQL12.EQ.1) THEN
56223 CALL PYJOIN(2,IJOIN)
56225 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56226 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56227 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56228 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56231 IF(IQL34.EQ.1) THEN
56234 CALL PYJOIN(2,IJOIN)
56236 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
56237 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
56238 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
56239 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
56242 C...Optionally do colour reconnection.
56245 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
56246 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
56250 C...Do fragmentation and decays. Possibly except tau decay.
56254 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56268 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56276 C*********************************************************************
56279 C...An interface from a six-fermion generator to include
56280 C...parton showers and hadronization.
56282 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
56284 C...Double precision and integer declarations.
56285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56286 IMPLICIT INTEGER(I-N)
56287 INTEGER PYK,PYCHGE,PYCOMP
56289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56291 SAVE /PYJETS/,/PYDAT1/
56293 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
56295 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56301 C...Loop through entries and pick up all final fermions/antifermions.
56309 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56311 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
56312 IF(K(I,2).GT.0) THEN
56315 ELSEIF(I3.EQ.0) THEN
56317 ELSEIF(I5.EQ.0) THEN
56320 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
56325 ELSEIF(I4.EQ.0) THEN
56327 ELSEIF(I6.EQ.0) THEN
56330 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
56336 C...Check that event is arranged according to conventions.
56337 IF(I5.EQ.0.OR.I6.EQ.0) THEN
56338 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
56340 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
56341 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
56344 C...Check which fermion pairs are quarks and which leptons.
56345 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
56347 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
56350 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
56352 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56354 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
56357 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
56359 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
56361 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
56364 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
56367 C...Decide whether to allow or not photon radiation in showers.
56369 IF(IRAD.EQ.0) MSTJ(41)=1
56371 C...Allow dipole pairings only among leptons and quarks separately.
56374 IF(IQL34.EQ.IQL56) P13D=P13
56376 IF(IQL12.EQ.IQL34) P21D=P21
56378 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
56380 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
56382 IF(IQL12.EQ.IQL56) P32D=P32
56384 C...Decide whether t+tbar.
56386 IF(PYR(0).LT.PTOP) THEN
56389 C...If t+tbar: reconstruct t's.
56395 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
56396 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
56404 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
56406 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
56410 C...If t+tbar: colour join t's and let them shower.
56413 CALL PYJOIN(2,IJOIN)
56414 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
56415 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
56416 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
56418 C...If t+tbar: pick up the t's after shower.
56422 IF(K(I,2).EQ.6) ITNEW=I
56423 IF(K(I,2).EQ.-6) ITBNEW=I
56426 C...If t+tbar: loop over two top systems.
56441 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
56442 & '(PY6FRM:) not b in t decay')
56444 C...If t+tbar: find boost from original to new top frame.
56446 BETAO(J)=P(ITO,J)/P(ITO,4)
56447 BETAN(J)=P(ITN,J)/P(ITN,4)
56450 C...If t+tbar: boost copy of b by t shower and connect it in colour.
56460 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56461 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56462 K(IB,4)=MSTU(5)*ITN
56463 K(IB,5)=MSTU(5)*ITN
56464 K(ITN,4)=K(ITN,4)+IB
56465 K(ITN,5)=K(ITN,5)+IB
56466 K(ITN,1)=K(ITN,1)+10
56467 K(IBO,1)=K(IBO,1)+10
56469 C...If t+tbar: construct W recoiling against b.
56477 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
56478 IF(IABS(KCHW).EQ.3) THEN
56479 K(IW,2)=ISIGN(24,KCHW)
56481 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
56485 C...If t+tbar: construct W momentum, including boost by t shower.
56487 P(IW,J)=P(IW1,J)+P(IW2,J)
56489 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
56491 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56492 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56494 C...If t+tbar: boost b and W to top rest frame.
56496 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
56498 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56499 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56501 C...If t+tbar: let b shower and pick up modified W.
56502 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
56503 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
56504 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
56506 IF(IABS(K(I,2)).EQ.24) IWM=I
56509 C...If t+tbar: take copy of W decay products.
56518 K(IW1,1)=K(IW1,1)+10
56519 K(IW2,1)=K(IW2,1)+10
56520 K(IWM,1)=K(IWM,1)+10
56534 C...If t+tbar: boost W decay products, first by effects of t shower,
56535 C...then by those of b shower. b and its shower simple boost back.
56536 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56537 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56538 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56539 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
56540 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
56541 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
56542 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
56543 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
56544 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
56548 C...Decide on dipole pairing.
56552 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
56553 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
56557 ELSEIF(PRN.LT.P12D+P13D) THEN
56561 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
56565 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
56569 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
56579 C...Do colour joinings and parton showers
56580 C...(except ones already made for t+tbar).
56582 IF(IQL12.EQ.1) THEN
56585 CALL PYJOIN(2,IJOIN)
56587 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56588 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56589 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56590 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56593 IF(IQL34.EQ.1) THEN
56596 CALL PYJOIN(2,IJOIN)
56598 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
56599 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
56600 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
56601 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
56603 IF(IQL56.EQ.1) THEN
56606 CALL PYJOIN(2,IJOIN)
56608 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
56609 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
56610 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
56611 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
56614 C...Do fragmentation and decays. Possibly except tau decay.
56618 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56632 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56640 C*********************************************************************
56643 C...An interface from a four-parton generator to include
56644 C...parton showers and hadronization.
56646 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
56648 C...Double precision and integer declarations.
56649 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56650 IMPLICIT INTEGER(I-N)
56651 INTEGER PYK,PYCHGE,PYCOMP
56653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56655 SAVE /PYJETS/,/PYDAT1/
56657 DIMENSION IJOIN(2),PTOT(4),BETA(3)
56659 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56665 C...Loop through entries and pick up all final partons.
56671 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56673 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
56674 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
56677 ELSEIF(I3.EQ.0) THEN
56680 CALL PYERRM(16,'(PY4JET:) more than two quarks')
56682 ELSEIF(K(I,2).LT.0) THEN
56685 ELSEIF(I4.EQ.0) THEN
56688 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
56693 ELSEIF(I4.EQ.0) THEN
56696 CALL PYERRM(16,'(PY4JET:) more than two gluons')
56702 C...Check that event is arranged according to conventions.
56703 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
56704 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
56706 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
56707 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
56710 C...Check whether second pair are quarks or gluons.
56711 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56713 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
56716 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
56719 C...Boost partons to their cm frame.
56721 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
56723 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
56725 BETA(J)=PTOT(J)/PTOT(4)
56727 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56728 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56729 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56730 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56733 C...Decide and set up shower history for q qbar q' qbar' events.
56734 IF(IQG34.EQ.1) THEN
56735 W1=PY4JTW(0,I1,I3,I4)
56736 W2=PY4JTW(0,I2,I3,I4)
56737 IF(W1.GT.PYR(0)*(W1+W2)) THEN
56738 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
56740 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
56743 C...Decide and set up shower history for q qbar g g events.
56745 W1=PY4JTW(I1,I3,I2,I4)
56746 W2=PY4JTW(I1,I4,I2,I3)
56747 W3=PY4JTW(0,I3,I1,I4)
56748 W4=PY4JTW(0,I4,I1,I3)
56749 W5=PY4JTW(0,I3,I2,I4)
56750 W6=PY4JTW(0,I4,I2,I3)
56751 W7=PY4JTW(0,I1,I3,I4)
56752 W8=PY4JTW(0,I2,I3,I4)
56753 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
56755 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
56756 ELSEIF(W1+W2.GT.WR) THEN
56757 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
56758 ELSEIF(W1+W2+W3.GT.WR) THEN
56759 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
56760 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
56761 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
56762 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
56763 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
56764 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
56765 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
56766 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
56767 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
56769 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
56773 C...Boost back original partons and mark them as deleted.
56774 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
56775 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
56776 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
56777 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
56783 C...Rotate shower initiating partons to be along z axis.
56784 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
56785 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
56786 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
56787 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
56789 C...Set up copy of shower initiating partons as on mass shell.
56799 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
56810 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
56811 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
56813 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
56815 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
56818 C...Decide whether to allow or not photon radiation in showers.
56819 C...Connect up colours.
56821 IF(IRAD.EQ.0) MSTJ(41)=1
56824 CALL PYJOIN(2,IJOIN)
56826 C...Decide on maximum virtuality and do parton shower.
56827 IF(PMAX.LT.PARJ(82)) THEN
56832 CALL PYSHOW(NSAV+1,-100,PQMAX)
56834 C...Rotate and boost back system.
56835 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
56837 C...Do fragmentation and decays.
56840 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56849 C*********************************************************************
56852 C...Auxiliary to PY4JET, to evaluate weight of configuration.
56854 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
56856 C...Double precision and integer declarations.
56857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56858 IMPLICIT INTEGER(I-N)
56859 INTEGER PYK,PYCHGE,PYCOMP
56861 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56864 C...First case: when both original partons radiate.
56865 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
56868 P(N+1,J)=P(IA1,J)+P(IA2,J)
56869 P(N+2,J)=P(IA3,J)+P(IA4,J)
56871 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56873 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56875 Z1=P(IA1,4)/P(N+1,4)
56876 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
56877 Z2=P(IA3,4)/P(N+2,4)
56878 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
56880 C...Second case: when one original parton radiates to three.
56881 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
56884 P(N+2,J)=P(IA3,J)+P(IA4,J)
56885 P(N+1,J)=P(N+2,J)+P(IA2,J)
56887 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56889 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56891 IF(K(IA2,2).EQ.21) THEN
56892 Z1=P(N+2,4)/P(N+1,4)
56893 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
56896 Z1=P(IA2,4)/P(N+1,4)
56897 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
56900 Z2=P(IA3,4)/P(N+2,4)
56901 IF(K(IA2,2).EQ.21) THEN
56902 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
56904 ELSEIF(K(IA3,2).EQ.21) THEN
56905 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
56907 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
56917 C*********************************************************************
56920 C...Auxiliary to PY4JET, to set up chosen configuration.
56922 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
56924 C...Double precision and integer declarations.
56925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56926 IMPLICIT INTEGER(I-N)
56927 INTEGER PYK,PYCHGE,PYCOMP
56929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56941 C...First case: when both original partons radiate.
56942 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
56945 C...Set up flavour and history pointers for new partons.
56963 C...Set up momenta for new partons.
56965 P(N+1,J)=P(IA1,J)+P(IA2,J)
56966 P(N+2,J)=P(IA3,J)+P(IA4,J)
56972 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56974 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56976 QMAX=MIN(P(N+1,5),P(N+2,5))
56978 C...Second case: q radiates twice.
56979 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
56980 C...IA5=N+2 does not radiate.
56981 ELSEIF(K(IA2,2).EQ.21) THEN
56983 C...Set up flavour and history pointers for new partons.
57001 C...Set up momenta for new partons.
57003 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
57005 P(N+3,J)=P(IA3,J)+P(IA4,J)
57010 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57012 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
57016 C...Third case: q radiates g, g branches.
57017 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
57018 C...IA5=N+2 does not radiate.
57021 C...Set up flavour and history pointers for new partons.
57039 C...Set up momenta for new partons.
57041 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
57044 P(N+4,J)=P(IA3,J)+P(IA4,J)
57048 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57050 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
57060 C*********************************************************************
57063 C...Connects a sequence of partons with colour flow indices,
57064 C...as required for subsequent shower evolution (or other operations).
57066 SUBROUTINE PYJOIN(NJOIN,IJOIN)
57068 C...Double precision and integer declarations.
57069 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57070 IMPLICIT INTEGER(I-N)
57071 INTEGER PYK,PYCHGE,PYCOMP
57073 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57074 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57075 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57076 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57080 C...Check that partons are of right types to be connected.
57081 IF(NJOIN.LT.2) GOTO 120
57085 IF(I.LE.0.OR.I.GT.N) GOTO 120
57086 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
57088 IF(KC.EQ.0) GOTO 120
57089 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
57090 IF(KQ.EQ.0) GOTO 120
57091 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
57092 IF(KQ.NE.2) KQSUM=KQSUM+KQ
57093 IF(IJN.EQ.1) KQS=KQ
57095 IF(KQSUM.NE.0) GOTO 120
57097 C...Connect the partons sequentially (closing for gluon loop).
57099 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
57103 IF(IJN.NE.1) IP=IJOIN(IJN-1)
57104 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
57105 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
57106 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
57107 K(I,KCS)=MSTU(5)*IN
57108 K(I,9-KCS)=MSTU(5)*IP
57109 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
57110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
57113 C...Error exit: no action taken.
57115 120 CALL PYERRM(12,
57116 &'(PYJOIN:) given entries can not be joined by one string')
57121 C*********************************************************************
57124 C...Sets values of commonblock variables.
57126 SUBROUTINE PYGIVE(CHIN)
57128 C...Double precision and integer declarations.
57129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57130 IMPLICIT INTEGER(I-N)
57131 INTEGER PYK,PYCHGE,PYCOMP
57133 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57134 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57135 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57136 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57137 COMMON/PYDAT4/CHAF(500,2)
57139 COMMON/PYDATR/MRPY(6),RRPY(100)
57140 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57141 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57142 COMMON/PYINT1/MINT(400),VINT(400)
57143 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
57144 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
57145 COMMON/PYINT4/MWID(500),WIDS(500,5)
57146 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
57147 COMMON/PYINT6/PROC(0:500)
57149 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
57150 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
57152 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57153 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57154 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57155 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
57156 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
57157 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
57158 C...Local arrays and character variables.
57159 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
57160 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
57162 DIMENSION MSVAR(54,8)
57164 C...For each variable to be translated give: name,
57165 C...integer/real/character, no. of indices, lower&upper index bounds.
57166 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
57167 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
57168 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
57169 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
57170 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
57171 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
57173 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
57174 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
57175 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
57176 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
57177 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
57178 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
57179 &1,1,1,6,4*0, 2,1,1,100,4*0,
57180 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
57181 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
57182 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
57183 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
57184 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
57185 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
57186 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
57187 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
57188 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
57189 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
57190 &1,1,0,99,4*0, 2,1,0,99,4*0/
57191 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
57192 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
57194 C...Length of character variable. Subdivide it into instructions.
57195 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
57196 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
57200 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
57203 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
57205 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
57210 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
57212 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
57214 C...Send off decay-mode on/off commands to PYONOF.
57217 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
57219 IF(IONOF.EQ.1) THEN
57224 C...Peel off any text following exclamation mark.
57226 DO 140 LLOW2=LHIG2,1,-1
57227 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
57229 IF(LBIT.EQ.0) RETURN
57231 C...Identify commonblock variable.
57234 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
57235 &LNAM.LE.6) GOTO 150
57236 CHNAM=CHBIT(1:LNAM-1)//' '
57237 DO 170 LCOM=1,LNAM-1
57239 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
57240 & CHALP(2)(LALP:LALP)
57245 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
57248 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
57250 IF(LLOW.LT.LTOT) GOTO 120
57254 C...Identify any indices.
57259 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
57262 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
57264 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
57265 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
57266 & IVAR.EQ.37)) THEN
57267 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
57268 READ(CHIND,'(I8)') KF
57270 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
57272 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
57275 IF(LLOW.LT.LTOT) GOTO 120
57278 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57279 READ(CHIND,'(I8)') I1
57282 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
57285 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
57288 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
57290 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57291 READ(CHIND,'(I8)') I2
57293 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
57296 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
57299 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
57301 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57302 READ(CHIND,'(I8)') I3
57307 C...Check that indices allowed.
57309 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
57310 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
57312 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
57314 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
57316 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
57318 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
57321 IF(LLOW.LT.LTOT) GOTO 120
57325 C...Save old value of variable.
57328 ELSEIF(IVAR.EQ.2) THEN
57330 ELSEIF(IVAR.EQ.3) THEN
57332 ELSEIF(IVAR.EQ.4) THEN
57334 ELSEIF(IVAR.EQ.5) THEN
57336 ELSEIF(IVAR.EQ.6) THEN
57338 ELSEIF(IVAR.EQ.7) THEN
57340 ELSEIF(IVAR.EQ.8) THEN
57342 ELSEIF(IVAR.EQ.9) THEN
57344 ELSEIF(IVAR.EQ.10) THEN
57346 ELSEIF(IVAR.EQ.11) THEN
57348 ELSEIF(IVAR.EQ.12) THEN
57350 ELSEIF(IVAR.EQ.13) THEN
57352 ELSEIF(IVAR.EQ.14) THEN
57354 ELSEIF(IVAR.EQ.15) THEN
57356 ELSEIF(IVAR.EQ.16) THEN
57358 ELSEIF(IVAR.EQ.17) THEN
57359 CHOLD=CHAF(I1,I2)(1:8)
57360 ELSEIF(IVAR.EQ.18) THEN
57362 ELSEIF(IVAR.EQ.19) THEN
57364 ELSEIF(IVAR.EQ.20) THEN
57366 ELSEIF(IVAR.EQ.21) THEN
57368 ELSEIF(IVAR.EQ.22) THEN
57370 ELSEIF(IVAR.EQ.23) THEN
57372 ELSEIF(IVAR.EQ.24) THEN
57374 ELSEIF(IVAR.EQ.25) THEN
57376 ELSEIF(IVAR.EQ.26) THEN
57378 ELSEIF(IVAR.EQ.27) THEN
57380 ELSEIF(IVAR.EQ.28) THEN
57382 ELSEIF(IVAR.EQ.29) THEN
57384 ELSEIF(IVAR.EQ.30) THEN
57386 ELSEIF(IVAR.EQ.31) THEN
57388 ELSEIF(IVAR.EQ.32) THEN
57390 ELSEIF(IVAR.EQ.33) THEN
57391 IOLD=ICOL(I1,I2,I3)
57392 ELSEIF(IVAR.EQ.34) THEN
57394 ELSEIF(IVAR.EQ.35) THEN
57396 ELSEIF(IVAR.EQ.36) THEN
57398 ELSEIF(IVAR.EQ.37) THEN
57400 ELSEIF(IVAR.EQ.38) THEN
57402 ELSEIF(IVAR.EQ.39) THEN
57404 ELSEIF(IVAR.EQ.40) THEN
57406 ELSEIF(IVAR.EQ.41) THEN
57408 ELSEIF(IVAR.EQ.42) THEN
57409 ROLD=SIGT(I1,I2,I3)
57410 ELSEIF(IVAR.EQ.43) THEN
57412 ELSEIF(IVAR.EQ.44) THEN
57414 ELSEIF(IVAR.EQ.45) THEN
57416 ELSEIF(IVAR.EQ.46) THEN
57418 ELSEIF(IVAR.EQ.47) THEN
57420 ELSEIF(IVAR.EQ.48) THEN
57422 ELSEIF(IVAR.EQ.49) THEN
57424 ELSEIF(IVAR.EQ.50) THEN
57425 ROLD=RVLAM(I1,I2,I3)
57426 ELSEIF(IVAR.EQ.51) THEN
57427 ROLD=RVLAMP(I1,I2,I3)
57428 ELSEIF(IVAR.EQ.52) THEN
57429 ROLD=RVLAMB(I1,I2,I3)
57430 ELSEIF(IVAR.EQ.53) THEN
57432 ELSEIF(IVAR.EQ.54) THEN
57436 C...Print current value of variable. Loop back.
57437 IF(LNAM.GE.LBIT) THEN
57439 CHBIT(15:60)=' has the value '
57440 IF(MSVAR(IVAR,1).EQ.1) THEN
57441 WRITE(CHBIT(51:60),'(I10)') IOLD
57442 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57443 WRITE(CHBIT(47:60),'(F14.5)') ROLD
57444 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57449 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57451 IF(LLOW.LT.LTOT) GOTO 120
57455 C...Read in new variable value.
57456 IF(MSVAR(IVAR,1).EQ.1) THEN
57458 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
57459 READ(CHINI,'(I10)') INEW
57460 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57462 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
57464 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57465 CHNEW=CHBIT(LNAM+1:LBIT)//' '
57467 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
57470 C...Store new variable value.
57473 ELSEIF(IVAR.EQ.2) THEN
57475 ELSEIF(IVAR.EQ.3) THEN
57477 ELSEIF(IVAR.EQ.4) THEN
57479 ELSEIF(IVAR.EQ.5) THEN
57481 ELSEIF(IVAR.EQ.6) THEN
57483 ELSEIF(IVAR.EQ.7) THEN
57485 ELSEIF(IVAR.EQ.8) THEN
57487 ELSEIF(IVAR.EQ.9) THEN
57489 ELSEIF(IVAR.EQ.10) THEN
57491 ELSEIF(IVAR.EQ.11) THEN
57493 ELSEIF(IVAR.EQ.12) THEN
57495 ELSEIF(IVAR.EQ.13) THEN
57497 ELSEIF(IVAR.EQ.14) THEN
57499 ELSEIF(IVAR.EQ.15) THEN
57501 ELSEIF(IVAR.EQ.16) THEN
57503 ELSEIF(IVAR.EQ.17) THEN
57505 ELSEIF(IVAR.EQ.18) THEN
57507 ELSEIF(IVAR.EQ.19) THEN
57509 ELSEIF(IVAR.EQ.20) THEN
57511 ELSEIF(IVAR.EQ.21) THEN
57513 ELSEIF(IVAR.EQ.22) THEN
57515 ELSEIF(IVAR.EQ.23) THEN
57517 ELSEIF(IVAR.EQ.24) THEN
57519 ELSEIF(IVAR.EQ.25) THEN
57521 ELSEIF(IVAR.EQ.26) THEN
57523 ELSEIF(IVAR.EQ.27) THEN
57525 ELSEIF(IVAR.EQ.28) THEN
57527 ELSEIF(IVAR.EQ.29) THEN
57529 ELSEIF(IVAR.EQ.30) THEN
57531 ELSEIF(IVAR.EQ.31) THEN
57533 ELSEIF(IVAR.EQ.32) THEN
57535 ELSEIF(IVAR.EQ.33) THEN
57536 ICOL(I1,I2,I3)=INEW
57537 ELSEIF(IVAR.EQ.34) THEN
57539 ELSEIF(IVAR.EQ.35) THEN
57541 ELSEIF(IVAR.EQ.36) THEN
57543 ELSEIF(IVAR.EQ.37) THEN
57545 ELSEIF(IVAR.EQ.38) THEN
57547 ELSEIF(IVAR.EQ.39) THEN
57549 ELSEIF(IVAR.EQ.40) THEN
57551 ELSEIF(IVAR.EQ.41) THEN
57553 ELSEIF(IVAR.EQ.42) THEN
57554 SIGT(I1,I2,I3)=RNEW
57555 ELSEIF(IVAR.EQ.43) THEN
57557 ELSEIF(IVAR.EQ.44) THEN
57559 ELSEIF(IVAR.EQ.45) THEN
57561 ELSEIF(IVAR.EQ.46) THEN
57563 ELSEIF(IVAR.EQ.47) THEN
57565 ELSEIF(IVAR.EQ.48) THEN
57567 ELSEIF(IVAR.EQ.49) THEN
57569 ELSEIF(IVAR.EQ.50) THEN
57570 RVLAM(I1,I2,I3)=RNEW
57571 ELSEIF(IVAR.EQ.51) THEN
57572 RVLAMP(I1,I2,I3)=RNEW
57573 ELSEIF(IVAR.EQ.52) THEN
57574 RVLAMB(I1,I2,I3)=RNEW
57575 ELSEIF(IVAR.EQ.53) THEN
57577 ELSEIF(IVAR.EQ.54) THEN
57581 C...Write old and new value. Loop back.
57583 CHBIT(15:60)=' changed from to '
57584 IF(MSVAR(IVAR,1).EQ.1) THEN
57585 WRITE(CHBIT(33:42),'(I10)') IOLD
57586 WRITE(CHBIT(51:60),'(I10)') INEW
57587 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57588 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57589 WRITE(CHBIT(29:42),'(F14.5)') ROLD
57590 WRITE(CHBIT(47:60),'(F14.5)') RNEW
57591 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57592 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57595 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57597 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
57598 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
57601 IF(LLOW.LT.LTOT) GOTO 120
57603 C...Format statement for output on unit MSTU(11) (by default 6).
57604 5000 FORMAT(5X,A60)
57605 5100 FORMAT(5X,A88)
57610 C*********************************************************************
57613 C...Switches on and off decay channel by search for match.
57615 SUBROUTINE PYONOF(CHIN)
57617 C...Double precision and integer declarations.
57618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57619 IMPLICIT INTEGER(I-N)
57620 INTEGER PYK,PYCHGE,PYCOMP
57622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57623 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57624 SAVE /PYDAT1/,/PYDAT3/
57625 C...Local arrays and character variables.
57626 INTEGER KFCMP(10),KFTMP(10)
57627 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
57629 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
57630 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
57632 C...Determine length of character variable.
57636 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
57639 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
57641 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
57643 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
57645 C...Find colon separator and particle code.
57647 120 LCOLON=LCOLON+1
57648 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
57650 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
57651 READ(CHCODE,'(I8)',ERR=300) KF
57654 C...Done if unknown code or no decay channels.
57656 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
57661 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
57662 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
57666 C...Find command name up to blank or equal sign.
57669 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
57670 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
57672 LMODE=LSEP-LCOLON-1
57673 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
57675 C...Convert to uppercase.
57676 DO 150 LCOM=1,LMODE
57678 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
57679 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
57683 C...Identify command. Failed if not identified.
57685 IF(CHMODE.EQ.'ALLOFF') MODE=1
57686 IF(CHMODE.EQ.'ALLON') MODE=2
57687 IF(CHMODE.EQ.'OFFIFANY') MODE=3
57688 IF(CHMODE.EQ.'ONIFANY') MODE=4
57689 IF(CHMODE.EQ.'OFFIFALL') MODE=5
57690 IF(CHMODE.EQ.'ONIFALL') MODE=6
57691 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
57692 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
57694 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
57698 C...Simple cases when all on or all off.
57699 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
57700 WRITE(MSTU(11),1000) KF,CHMODE
57701 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
57702 IF(MDME(IDC,1).LT.0) GOTO 160
57708 C...Identify matching list.
57712 IF(LBEG.GT.LEN) GOTO 190
57713 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
57714 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
57717 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
57718 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
57719 IF(LEND.LT.LEN) LEND=LEND-1
57721 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
57722 READ(CHCODE,'(I8)',ERR=300) KFREAD
57724 KFCMP(NCMP)=IABS(KFREAD)
57726 IF(NCMP.LT.10) GOTO 170
57728 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
57730 C...Only one matching required.
57731 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
57732 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
57733 IF(MDME(IDC,1).LT.0) GOTO 220
57735 KFNOW=IABS(KFDP(IDC,IKF))
57736 IF(KFNOW.EQ.0) GOTO 210
57738 IF(KFCMP(ICMP).EQ.KFNOW) THEN
57748 C...Multiple matchings required.
57749 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
57750 IF(MDME(IDC,1).LT.0) GOTO 260
57753 KFTMP(ITMP)=KFCMP(ITMP)
57757 KFNOW=IABS(KFDP(IDC,IKF))
57758 IF(KFNOW.EQ.0) GOTO 250
57761 IF(KFTMP(ITMP).EQ.KFNOW) THEN
57762 KFTMP(ITMP)=KFTMP(NTMP)
57768 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
57769 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
57770 & MDME(IDC,1)=MODE-7
57774 C...Error exit for impossible read of particle code.
57775 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
57778 C...Formats for output.
57779 1000 FORMAT(' Decays for',I8,' set ',A10)
57780 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
57785 C*********************************************************************
57788 C...Presets for a few specific underlying-event and min-bias tunes
57789 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
57790 C...others require particular versions of pythia (e.g. the SCI and GAL
57791 C...models). See below for details.
57792 SUBROUTINE PYTUNE(ITUNE)
57794 C ITUNE NAME (detailed descriptions below)
57795 C 0 Default : No settings changed => linked Pythia version's defaults.
57796 C ====== Old UE, Q2-ordered showers ==========================================
57797 C 100 A : Rick Field's Tune A
57798 C 101 AW : Rick Field's Tune AW
57799 C 102 BW : Rick Field's Tune BW
57800 C 103 DW : Rick Field's Tune DW
57801 C 104 DWT : Rick Field's Tune DW with slower UE energy scaling
57802 C 105 QW : Rick Field's Tune QW (NB: needs CTEQ6.1 pdfs externally)
57803 C 106 ATLAS : Arthur Moraes' ATLAS tune
57804 C 107 ACR : Tune A modified with annealing CR
57805 C ====== New UE, Q2-ordered showers ==========================================
57806 C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
57807 C ====== New UE, interleaved pT-ordered showers, annealing CR ================
57808 C 300 S0 : Sandhoff-Skands Tune 0
57809 C 301 S1 : Sandhoff-Skands Tune 1
57810 C 302 S2 : Sandhoff-Skands Tune 2
57811 C 303 S0A : S0 with "Tune A" UE energy scaling
57812 C 304 NOCR : New UE "best try" without colour reconnections.
57813 C 305 Old : New UE, original (primitive) colour reconnections
57814 C ======= The Uppsala models =================================================
57815 C ( NB! must be run with special modified Pythia 6.215 version )
57816 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
57817 C 400 GAL 0 : Generalized area-law model. Old parameters.
57818 C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters.
57819 C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned.
57820 C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned.
57824 C Quick Dictionary:
57825 C BE : Bose-Einstein
57826 C BR : Beam Remnants
57827 C CR : Colour Reconnections
57828 C HAD: Hadronization
57829 C ISR/FSR: Initial-State Radiation / Final-State Radiation
57830 C FSI: Final-State Interactions (=CR+BE)
57831 C MB : Minimum-bias
57832 C MI : Multiple Interactions
57833 C UE : Underlying Event
57835 C A (100) and AW (101). Old UE model, Q2-ordered showers.
57836 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57837 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57838 C...Key feature: extensively compared to CDF data (R.D. Field).
57839 C...* Large starting scale for ISR (PARP(67)=4)
57840 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
57841 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57843 C BW (102). Old UE model, Q2-ordered showers.
57844 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57845 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57846 C...Key feature: extensively compared to CDF data (R.D. Field).
57847 C...NB: Can also be run with Pythia 6.2 or 6.312+
57848 C...* Small starting scale for ISR (PARP(67)=1)
57849 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
57850 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57852 C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
57853 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57854 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57855 C...Key feature: extensively compared to CDF data (R.D. Field).
57856 C...NB: Can also be run with Pythia 6.2 or 6.312+
57857 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
57858 C...* DWT has a different reference energy, the same as the "S" models
57859 C... below, leading to more UE activity at the LHC, but less at RHIC.
57860 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57862 C QW (105). Old UE model, Q2-ordered showers.
57863 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57864 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57865 C...Key feature: uses CTEQ61 (external pdf library must be linked)
57867 C ATLAS (106). Old UE model, Q2-ordered showers.
57868 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57869 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57870 C...Key feature: tune used by the ATLAS collaboration.
57872 C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
57873 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.408+ ***
57874 C...Key feature: Tune A modified to use annealing CR.
57875 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
57877 C...IM1 (200). Intermediate model, Q2-ordered showers.
57878 C...Key feature: new UE model with Q2-ordered showers and no interleaving.
57879 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
57880 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
57882 C S0 (300) and S0A (303). New UE model, pT-ordered showers.
57883 C...Key feature: large amount of multiple interactions
57884 C...* Somewhat faster than the other colour annealing scenarios.
57885 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
57886 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
57887 C...* Small amount of radiation.
57888 C...* Large amount of low-pT MI
57889 C...* Low degree of proton lumpiness (broad matter dist.)
57890 C...* CR Type S (driven by free triplets), of medium strength.
57891 C...* See: Pythia6402 update notes or later.
57893 C S1 (301). New UE model, pT-ordered showers.
57894 C...Key feature: large amount of radiation.
57895 C...* Large amount of low-pT perturbative ISR
57896 C...* Large amount of FSR off ISR partons
57897 C...* Small amount of low-pT multiple interactions
57898 C...* Moderate degree of proton lumpiness
57899 C...* Least aggressive CR type (S+S Type I), but with large strength
57900 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
57902 C S2 (302). New UE model, pT-ordered showers.
57903 C...Key feature: very lumpy proton + gg string cluster formation allowed
57904 C...* Small amount of radiation
57905 C...* Moderate amount of low-pT MI
57906 C...* High degree of proton lumpiness (more spiky matter distribution)
57907 C...* Most aggressive CR type (S+S Type II), but with small strength
57908 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
57910 C NOCR (304). New UE model, pT-ordered showers.
57911 C...Key feature: no colour reconnections (NB: "Best fit" only).
57912 C...* NB: <pT>(Nch) problematic in this tune.
57913 C...* Small amount of radiation
57914 C...* Small amount of low-pT MI
57915 C...* Low degree of proton lumpiness
57916 C...* Large BR composite x enhancement factor
57917 C...* Most clever colour flow without CR ("Lambda ordering")
57919 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
57920 C...with an unmodified Pythia distribution.
57921 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
57923 C ::: + Future improvements?
57924 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ?
57925 C (problem: K-factor affects everything so only works as
57926 C intended for min-bias, not for UE ... probably need a
57927 C better long-term solution to handle UE as well. Anyway,
57928 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
57930 C...Global statements
57931 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57932 INTEGER PYK,PYCHGE,PYCOMP
57935 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57936 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57938 C...SCI and GAL Commonblocks
57939 COMMON /SCIPAR/MSWI(2),PARSCI(2)
57941 C...Internal parameters
57942 PARAMETER(MXTUNS=500)
57943 CHARACTER*8 CHVERS, CHDOC
57944 PARAMETER (CHVERS='1.000 ',CHDOC='Oct 2006')
57945 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
57946 CHARACTER*40 CHMSTJ(20), CHMSTP(51:100), CHPARP(61:100),
57947 & CHPARJ(41:100), CH40
57950 DATA (CHNAMS(I),I=0,1)/'Default',' '/
57951 DATA (CHNAMS(I),I=100,110)/
57952 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
57953 & 'ATLAS Tune','Tune ACR',3*' '/
57954 DATA (CHNAMS(I),I=300,310)/
57955 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',5*' '/
57956 DATA (CHNAMS(I),I=200,210)/
57957 & 'IM Tune 1',10*' '/
57958 DATA (CHNAMS(I),I=400,410)/
57959 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
57960 DATA (CHMSTJ(I),I=11,20)/
57961 & 5*' ','HAD treatment of small-mass systems',4*' '/
57962 DATA (CHMSTP(I),I=51,100)/
57963 5 'PDF set','PDF set internal (=1) or pdflib (=2)',
57964 6 8*' ','ISR master switch',8*' ',
57965 7 'ISR IR regularization scheme',' ',
57966 7 'ISR scheme for FSR off ISR',8*' ',
57968 8 'UE hadron transverse mass distribution',5*' ',
57969 8 'BR composite scheme','BR colour scheme',1*' ',
57970 9 'BR primordial kT distribution',
57971 9 'BR energy partitioning scheme',2*' ',
57972 9 'FSI colour (re-)connection model',5*' '/
57973 DATA (CHPARP(I),I=61,100)/
57974 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
57975 6 2*' ','ISR Q2max factor',3*' ',
57976 7 'FSR Q2max factor for non-s-channel procs',5*' ',
57977 7 'FSI colour reconnection turnoff scale',
57978 7 'FSI colour reconnection strength',
57979 7 'BR composite x enhancement','BR breakup suppression',
57980 8 2*'UE IR cutoff at reference ecm',
57981 8 2*'UE mass distribution parameter',
57982 8 'UE gg colour correlated fraction','UE total gg fraction',
57984 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
57985 9 'BR primordial kT width <|kT|>',' ',
57986 9 'BR primordial kT UV cutoff',7*' '/
57987 DATA (CHPARJ(I),I=41,90)/
57988 4 ' ','HAD string parameter b',8*' ',10*' ',10*' ',10*' ',
57989 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
57990 SAVE /PYDAT1/,/PYPARS/
57993 C...1) Shorthand notation
57996 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
57997 CHNAME=CHNAMS(ITUNE)
57998 IF (ITUNE.EQ.0) GOTO 9999
58000 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
58005 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
58007 C...3) Tune parameters
58009 C=============================================================================
58010 C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
58011 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
58012 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
58013 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
58014 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58023 C...UE on, new model.
58025 C...Slow IR cutoff energy scaling by default
58028 C...Switch off trial joinings
58030 C...Primordial kT cutoff
58033 C...S0 (300), S0A (303)
58034 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
58036 CH60='see PYTHIA 6.402+ update notes,'
58037 WRITE(M11,5030) CH60
58038 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120,'
58039 WRITE(M11,5030) CH60
58040 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58041 WRITE(M11,5030) CH60
58043 C...Smooth ISR, low FSR
58048 C...Transverse density profile.
58051 C...Colour Reconnections
58055 C... Reference energy for pT0 and energy scaling pace.
58056 IF (ITUNE.EQ.303) PARP(90)=0.25D0
58057 C...Lambda_FSR scale.
58061 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
58068 ELSEIF(ITUNE.EQ.301) THEN
58070 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
58071 WRITE(M11,5030) CH60
58072 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58073 WRITE(M11,5030) CH60
58075 C... Sharp ISR, high FSR
58080 C... Colour Reconnections
58083 C... Transverse density profile.
58086 C... Lambda_FSR scale.
58090 C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58097 ELSEIF(ITUNE.EQ.302) THEN
58099 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
58100 WRITE(M11,5030) CH60
58101 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58102 WRITE(M11,5030) CH60
58104 C... Smooth ISR, low FSR
58109 C... Transverse density profile.
58112 C... Colour Reconnections
58115 C... Lambda_FSR scale.
58119 C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58126 ELSEIF(ITUNE.EQ.304) THEN
58128 CH60='"best try" without colour reconnections'
58129 WRITE(M11,5030) CH60
58130 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
58131 WRITE(M11,5030) CH60
58133 C... Smooth ISR, low FSR
58138 C... Transverse density profile.
58141 C... Colour Reconnections
58143 C... Lambda_FSR scale.
58147 C... Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
58153 C..."Lo FSR" retune (305)
58154 ELSEIF(ITUNE.EQ.305) THEN
58156 CH60='"Lo FSR retune" with primitive colour reconnections'
58157 WRITE(M11,5030) CH60
58158 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
58159 WRITE(M11,5030) CH60
58161 C... Smooth ISR, low FSR
58166 C... Transverse density profile.
58169 C... Colour Reconnections
58172 C... Lambda_FSR scale.
58176 C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58184 WRITE(M11,5030) ' '
58185 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58186 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58187 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58188 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
58189 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
58190 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58191 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58192 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58193 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58194 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58195 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58196 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58197 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58198 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
58199 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
58200 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
58201 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
58202 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58203 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58204 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58207 C=============================================================================
58208 C...Tunes A, AW, BW, DW, DWT, and QW (by R.D. Field, CDF) (100-105)
58209 C...and ATLAS Tune (by A. Moraes, ATLAS) (106)
58210 ELSEIF (ITUNE.GE.100.AND.ITUNE.LE.106) THEN
58211 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
58212 WRITE(M11,5010) ITUNE, CHNAME
58213 CH60='see R.D. Field (CDF), in hep-ph/0610012'
58214 WRITE(M11,5030) CH60
58215 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58216 WRITE(M11,5030) CH60
58218 C...Multiple interactions on, old framework
58220 C...Fast IR cutoff energy scaling by default
58223 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
58226 IF (ITUNE.EQ.105) THEN
58230 C...Double Gaussian matter distribution.
58236 C...Lambda_FSR scale.
58240 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
58243 c...String drawing almost completely minimizes string length.
58246 C...ISR cutoff, muR scale factor, and phase space size
58250 C...Intrinsic kT, size, and max
58254 C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
58255 IF (ITUNE.EQ.101) THEN
58262 C... Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
58263 ELSEIF (ITUNE.EQ.102) THEN
58266 c... String drawing completely minimizes string length.
58269 C... ISR cutoff, muR scale factor, and phase space size
58273 C... Intrinsic kT, size, and max
58279 ELSEIF (ITUNE.EQ.103) THEN
58282 c... String drawing completely minimizes string length.
58285 C... ISR cutoff, muR scale factor, and phase space size
58289 C... Intrinsic kT, size, and max
58295 ELSEIF (ITUNE.EQ.104) THEN
58298 C... Run II ref scale and slow scaling
58301 c... String drawing completely minimizes string length.
58304 C... ISR cutoff, muR scale factor, and phase space size
58308 C... Intrinsic kT, size, and max
58314 ELSEIF(ITUNE.EQ.105) THEN
58316 WRITE(M11,5030) ' '
58317 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
58318 & 'externally linked and'
58319 WRITE(M11,5035) CH70
58320 CH70='MSTP(51) should be set manually according to '//
58321 & 'the library used'
58322 WRITE(M11,5035) CH70
58326 c... String drawing completely minimizes string length.
58329 C... ISR cutoff, muR scale factor, and phase space size
58333 C... Intrinsic kT, size, and max
58339 ELSEIF(ITUNE.EQ.106) THEN
58341 WRITE(M11,5010) ITUNE, CHNAME
58342 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
58343 WRITE(M11,5030) CH60
58344 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58345 WRITE(M11,5030) CH60
58349 C... Different ref and rescaling pacee
58352 C... Parameters of mass distribution
58355 C... Old default string drawing
58358 C... ISR, phase space equivalent to Tune B
58373 WRITE(M11,5030) ' '
58374 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58375 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58376 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58377 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58378 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58379 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58380 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58381 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58382 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58383 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58384 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58385 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58386 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58387 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58388 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
58389 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
58390 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
58391 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
58392 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58395 C=============================================================================
58396 C... ACR, tune A with new CR (107)
58397 ELSEIF(ITUNE.EQ.107) THEN
58399 WRITE(M11,5010) ITUNE, CHNAME
58400 CH60='Tune A modified with new colour reconnections'
58401 WRITE(M11,5030) CH60
58402 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
58403 WRITE(M11,5030) CH60
58405 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
58406 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58407 & ' with tune. Using defaults.')
58433 WRITE(M11,5030) ' '
58434 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58435 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58436 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58437 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58438 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58439 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58440 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58441 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58442 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58443 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58444 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58445 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58446 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58447 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58448 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
58449 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
58450 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
58451 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
58452 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58453 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58454 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58457 C=============================================================================
58458 C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
58459 ELSEIF(ITUNE.EQ.200) THEN
58461 WRITE(M11,5010) ITUNE, CHNAME
58462 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
58463 WRITE(M11,5030) CH60
58465 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
58466 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58484 C... ExpOfPow(1.8) overlap profile
58491 C... Default diquark, BR-g-BR supp
58494 C... Final state reconnect.
58499 WRITE(M11,5030) ' '
58500 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58501 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58502 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58503 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58504 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58505 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58506 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58507 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58508 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58509 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58510 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58511 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58512 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58513 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
58514 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
58515 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
58516 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
58517 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58518 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58519 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58522 C=============================================================================
58523 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
58524 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
58526 WRITE(M11,5010) ITUNE, CHNAME
58527 CH60='see J. Rathsman, PLB452(1999)364'
58528 WRITE(M11,5030) CH60
58529 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
58530 C ? WRITE(M11,5030)
58531 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58532 WRITE(M11,5030) CH60
58533 WRITE(M11,5030) ' '
58534 CH70='NB! The GAL model must be run with modified '//
58536 WRITE(M11,5035) CH70
58537 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
58538 WRITE(M11,5035) CH70
58539 WRITE(M11,5030) ' '
58541 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
58554 IF(CHNAME.EQ.'GAL Tune 1') THEN
58555 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
58561 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58562 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58563 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58564 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58565 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58569 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58570 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
58571 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58576 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58577 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
58578 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
58579 CH40='FSI SCI/GAL selection'
58580 WRITE(M11,6040) 1, MSWI(1), CH40
58581 CH40='FSI SCI/GAL sea quark treatment'
58582 WRITE(M11,6040) 2, MSWI(2), CH40
58583 CH40='FSI SCI/GAL sea quark treatment parm'
58584 WRITE(M11,6050) 1, PARSCI(1), CH40
58585 CH40='FSI SCI/GAL string reco probability R_0'
58586 WRITE(M11,6050) 2, PARSCI(2), CH40
58587 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
58588 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
58590 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
58592 WRITE(M11,5010) ITUNE, CHNAME
58593 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
58594 WRITE(M11,5030) CH60
58595 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58596 WRITE(M11,5030) CH60
58597 WRITE(M11,5030) ' '
58598 CH70='NB! The SCI model must be run with modified '//
58600 WRITE(M11,5035) CH70
58601 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
58602 WRITE(M11,5035) CH70
58603 WRITE(M11,5030) ' '
58605 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
58615 IF (CHNAME.EQ.'SCI Tune 1') THEN
58616 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
58624 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58625 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58626 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58627 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58628 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58632 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58633 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
58634 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58639 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
58640 CH40='FSI SCI/GAL selection'
58641 WRITE(M11,6040) 1, MSWI(1), CH40
58642 CH40='FSI SCI/GAL sea quark treatment'
58643 WRITE(M11,6040) 2, MSWI(2), CH40
58644 CH40='FSI SCI/GAL sea quark treatment parm'
58645 WRITE(M11,6050) 1, PARSCI(1), CH40
58646 CH40='FSI SCI/GAL string reco probability R_0'
58647 WRITE(M11,6050) 2, PARSCI(2), CH40
58648 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
58652 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
58656 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
58660 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
58661 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
58662 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
58663 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
58664 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
58665 5030 FORMAT(' *',3x,10x,A60,3x,'*')
58666 5035 FORMAT(' *',3x,A70,3x,'*')
58667 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A40,5x,'*')
58668 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
58669 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
58670 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
58671 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
58672 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
58673 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
58674 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
58675 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
58679 C*********************************************************************
58682 C...Administrates the fragmentation and decay chain.
58686 C...Double precision and integer declarations.
58687 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58688 IMPLICIT INTEGER(I-N)
58689 INTEGER PYK,PYCHGE,PYCOMP
58691 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58692 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58693 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58694 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58695 COMMON/PYINT1/MINT(400),VINT(400)
58696 COMMON/PYINT4/MWID(500),WIDS(500,5)
58697 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
58699 DIMENSION PS(2,6),IJOIN(100)
58701 C...Initialize and reset.
58703 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58705 MSTU(31)=MSTU(31)+1
58709 IF(MSTU(17).LE.0) MSTU(90)=0
58712 C...Sum up momentum, energy and charge for starting entries.
58720 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
58722 PS(1,J)=PS(1,J)+P(I,J)
58724 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
58728 C...Start by all decays of coloured resonances involved in shower.
58731 IF(K(I,1).EQ.3) THEN
58733 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
58737 C...Prepare system for subsequent fragmentation/decay.
58739 IF(MINT(51).NE.0) RETURN
58741 C...Loop through jet fragmentation and particle decays.
58747 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
58750 C...Deal with any remaining undecayed resonance
58751 C...(normally the task of PYEVNT, so seldom used).
58752 ELSEIF(MWID(KC).NE.0) THEN
58754 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
58757 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
58758 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
58761 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
58762 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
58765 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
58773 IF(MINT(51).NE.0) RETURN
58775 C...Particle decay if unstable and allowed. Save long-lived particle
58776 C...decays until second pass after Bose-Einstein effects.
58777 ELSEIF(KCHG(KC,2).EQ.0) THEN
58778 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
58779 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
58782 C...Decay products may develop a shower.
58783 IF(MSTJ(92).GT.0) THEN
58785 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
58786 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
58788 CALL PYSHOW(IP1,IP1+1,QMAX)
58790 IF(MINT(51).NE.0) RETURN
58792 ELSEIF(MSTJ(92).LT.0) THEN
58795 CALL PYSHOW(IP1,-3,P(IP,5))
58797 IF(MINT(51).NE.0) RETURN
58801 C...Jet fragmentation: string or independent fragmentation.
58802 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
58804 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
58805 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
58806 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
58807 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
58808 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
58811 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
58812 IF(MFRAG.EQ.2) CALL PYINDF(IP)
58813 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
58814 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
58817 C...Loop back if enough space left in PYJETS and no error abort.
58818 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
58819 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
58821 ELSEIF(IP.LT.N) THEN
58822 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
58825 C...Include simple Bose-Einstein effect parametrization if desired.
58826 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
58831 C...Check that momentum, energy and charge were conserved.
58833 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
58835 PS(2,J)=PS(2,J)+P(I,J)
58837 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
58839 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
58840 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
58841 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
58842 &'(PYEXEC:) four-momentum was not conserved')
58843 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
58844 &'(PYEXEC:) charge was not conserved')
58849 C*********************************************************************
58852 C...Rearranges partons along strings.
58853 C...Special considerations for systems with junctions, with
58854 C...possibility of junction-antijunction annihilation.
58855 C...Allows small systems to collapse into one or two particles.
58856 C...Checks flavours and colour singlet invariant masses.
58858 SUBROUTINE PYPREP(IP)
58860 C...Double precision and integer declarations.
58861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58862 INTEGER PYK,PYCHGE,PYCOMP
58864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58868 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58869 COMMON/PYINT1/MINT(400),VINT(400)
58870 C...The common block of colour tags.
58871 COMMON/PYCTAG/NCT,MCT(4000,2)
58872 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
58877 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
58878 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
58879 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
58880 &IJCP(0:6),TJUOLD(5)
58883 C...Function to give four-product.
58884 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)
58886 C...Rearrange parton shower product listing along strings: begin loop.
58894 DO 100 I=MAX(1,IP),N
58895 C...First store junction positions.
58896 IF(K(I,1).EQ.42) THEN
58904 DO 240 I=MAX(1,IP),N
58905 C...Special treatment for junctions
58906 IF (K(I,1).LE.0) GOTO 240
58907 IF(K(I,1).EQ.42) THEN
58908 C...MQGST=2: Look for junction-junction strings (not detected in the
58909 C...main search below).
58910 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
58911 IF (NJJSTR.EQ.0) THEN
58912 NJJSTR = (3*NJUNC-NPIECE)/2
58914 C...Check how many already identified strings end on this junction
58917 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
58919 C...If less than 3, remaining must be to another junction
58922 C...Multiple j-j connections not handled yet.
58924 & '(PYPREP:) Too many junction-junction strings.')
58928 C...The colour information in the junction is unreadable for the
58929 C...colour space search further down in this routine, so we must
58930 C...start on the colour mother of this junction and then "artificially"
58931 C...prevent the colour mother from connecting here again.
58932 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
58934 IF (MOD(ITJUNC,2).EQ.0) KCS=5
58935 C...Switch colour if the junction-junction leg is presumably a
58936 C...junction mother leg rather than a junction daughter leg.
58937 IF (ITJUNC.GE.3) KCS=9-KCS
58938 IF (MINT(33).EQ.0) THEN
58939 C...Find the unconnected leg and reorder junction daughter pointers so
58940 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
58942 IA=MOD(K(I,4),MSTU(5))
58943 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
58944 ITMP=MOD(K(I,5),MSTU(5))
58945 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
58946 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
58947 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
58949 K(I,5)=K(I,5)+(IA-ITMP)
58951 K(I,4)=K(I,4)+(ITMP-IA)
58954 IF (ITJUNC.LE.2) THEN
58955 C...Beam baryon junction
58956 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
58957 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
58958 C...Else 1 -> 2 decay junction
58960 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
58961 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
58966 C...Alternatively use colour tag information.
58968 C...Find a final state parton with appropriate dangling colour tag.
58972 DO 140 J1=MAX(1,IP),N
58973 IF (K(J1,1).NE.3) GOTO 140
58974 C...Check for matching final-state colour tag
58976 DO 120 J2=MAX(1,IP),N
58977 IF (K(J2,1).NE.3) GOTO 120
58978 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
58980 IF (IMATCH.EQ.1) GOTO 140
58981 C...Check whether this colour tag belongs to the present junction
58982 C...by seeing whether any parton with this colour tag has the same
58983 C...mother as the junction.
58986 DO 130 J2=MINT(84)+1,N
58988 C...First scattering partons have IMO1 = 3 and 4.
58989 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
58991 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
58994 IF (IMATCH.EQ.0) GOTO 140
58997 C...Check for junction-junction strings without intermediate final state
58998 C...glue (not detected above).
59002 IF (IJU2.EQ.I) GOTO 160
59003 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
59004 C...Only opposite types of junctions can connect to each other.
59005 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
59008 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
59010 IF (IS.EQ.3) GOTO 160
59015 C...Switch to other side of adjacent parton and step from there.
59021 ELSE IF (ILC.NE.3) THEN
59026 C...Look for coloured string endpoint, or (later) leftover gluon.
59027 IF(K(I,1).NE.3) GOTO 240
59029 IF(KC.EQ.0) GOTO 240
59031 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
59033 C...Pick up loose string end.
59035 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
59041 IF(NSTP.GT.4*N) THEN
59042 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
59047 C...Copy undecayed parton. Finished if reached string endpoint.
59048 IF(K(IA,1).EQ.3) THEN
59049 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
59050 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
59057 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
59067 IF(K(I1,1).EQ.1) GOTO 240
59070 C...Also finished (for now) if reached junction; then copy to end.
59071 IF(K(IA,1).EQ.42) THEN
59073 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
59074 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
59079 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
59080 DO 200 ICOPY=1,NCOPY
59082 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
59083 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
59084 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
59088 C...For junction-junction strings, find end leg and reorder junction
59089 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
59090 C...junction-junction string piece.
59091 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
59092 ITMP=MOD(K(IA,4),MSTU(5))
59093 IF (ITMP.NE.IB) THEN
59094 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
59095 K(IA,5)=K(IA,5)+(ITMP-IB)
59097 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
59099 K(IA,4)=K(IA,4)+(IB-ITMP)
59104 C...0: endpoint in original ER
59107 C...3: Parton immediately next to junction
59110 IPIECE(NPIECE,1)=MSTU32+1
59111 IPIECE(NPIECE,2)=MSTU32+NCOPY
59112 IPIECE(NPIECE,3)=IB
59113 IPIECE(NPIECE,4)=IA
59114 MSTU32=MSTU32+NCOPY
59119 C...GOTO next parton in colour space.
59121 IF (MINT(33).EQ.0) THEN
59122 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
59124 IA=MOD(K(IB,KCS),MSTU(5))
59125 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
59128 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
59129 & MSTU(5)).EQ.0) KCS=9-KCS
59130 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
59131 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
59134 IF(IA.LE.0.OR.IA.GT.N) THEN
59135 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
59136 IF(NERRPR.LT.5) THEN
59138 WRITE(MSTU(11),*) 'started at:', I
59139 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
59140 WRITE(MSTU(11),*) 'MQGST =',MQGST
59146 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
59147 & ,MSTU(5)).EQ.IB) THEN
59148 IF(MREV.EQ.1) KCS=9-KCS
59149 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
59150 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
59152 IF(MREV.EQ.0) KCS=9-KCS
59153 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
59154 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
59156 IF(IA.NE.I) GOTO 170
59157 C...Use colour tag information
59159 C...First create colour tags starting on IB if none already present.
59160 IF (MCT(IB,KCS-3).EQ.0) THEN
59161 CALL PYCTTR(IB,KCS,IB)
59162 IF(MINT(51).NE.0) RETURN
59166 C...Find final state tag partner
59167 DO 210 IT=MAX(1,IP),N
59168 IF (IT.EQ.IB) GOTO 210
59169 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
59175 C...Just copy and goto next if exactly one partner found.
59176 IF (IFOUND.EQ.1) THEN
59178 C...When no match found, match is presumably junction.
59179 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
59180 C...Check whether this colour tag matches a junction
59181 C...by seeing whether any parton with this colour tag has the same
59182 C...mother as a junction.
59183 C...NB: Only type 1 and 2 junctions handled presently.
59185 IJUMO=K(IJUNC(IJU,0),3)
59186 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
59187 C...Colours only connect to junctions, anti-colours to antijunctions:
59188 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
59190 DO 220 J1=MAX(1,IP),N
59191 IF (K(J1,1).LE.0) GOTO 220
59192 C...First scattering partons have IMO1 = 3 and 4.
59194 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
59196 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
59197 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
59199 C...Attempt at handling type > 3 junctions also. Not tested.
59200 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
59203 IF (IMATCH.EQ.0) GOTO 230
59208 IF (IFOUND.EQ.1) THEN
59210 ELSEIF (IFOUND.EQ.0) THEN
59212 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
59214 IF(NERRPR.LT.5) THEN
59221 ELSEIF (IFOUND.GE.2) THEN
59224 & ,'(PYPREP:) too many occurences of colour line: '//
59226 IF(NERRPR.LT.5) THEN
59238 C...Junction systems remain.
59244 260 IJUCNT=IJUCNT+1
59245 IF (IJUCNT.LE.NJUNC) THEN
59246 C...If we are not processing a j-j string, treat this junction as new.
59247 IF (IJJSTR.EQ.0) THEN
59248 IJU=IJUNC(IJUCNT,0)
59250 C...If junction has already been read, ignore it.
59251 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
59252 C...If we are on a j-j string, goto second j-j junction.
59257 C...Mark selected junction read.
59259 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
59261 C...Determine junction type
59262 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
59263 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
59264 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
59265 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
59266 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
59269 C...Find which quarks belong to given junction.
59271 DO 290 IPC=1,NPIECE
59272 IF (IPIECE(IPC,4).EQ.IJU) THEN
59274 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
59276 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
59278 C...IHK = 3 is special. Either normal string piece, or j-j string.
59280 IF (MREV.NE.1) THEN
59281 DO 300 IPC=1,NPIECE
59282 C...If there is a j-j string starting on the present junction which has
59283 C...zero length, insert next junction immediately.
59284 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
59285 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
59291 C...If MREV is 1 and IHK is 3 we are finished with this system.
59298 C...If we've gotten this far, then either IHK < 3, or
59299 C...an interjunction string exists, or just a third normal string.
59300 IJUNC(IJUCNT,IHK)=0
59302 C..Order pieces belonging to this junction. Also look for j-j.
59303 DO 310 IPC=1,NPIECE
59304 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
59305 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
59306 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
59307 IJUNC(IJUCNT,IHK)=IPC
59312 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
59313 IPC=IJUNC(IJUCNT,IHK)
59314 C...Temporary solution to cover for bug.
59316 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
59320 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
59323 K(I1,J)=K(MSTU(4)-ICP,J)
59324 P(I1,J)=P(MSTU(4)-ICP,J)
59325 V(I1,J)=V(MSTU(4)-ICP,J)
59329 C...Mark last quark.
59330 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
59331 C...Do not insert junctions at wrong places.
59332 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
59333 C...Insert junction.
59336 C...Shift to end junction if a j-j string has been processed.
59337 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
59347 K(IJUS,1)=K(IJUS,1)+10
59350 360 IF (IHK.LT.3) GOTO 280
59352 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
59356 IF (IJUCNT.NE.NJUNC) GOTO 260
59360 C...Rearrange three strings from junction, e.g. in case one has been
59361 C...shortened by shower, so the last is the largest-energy one.
59362 IF(NJUNC.GE.1) THEN
59363 C...Find systems with exactly one junction.
59367 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
59368 ELSEIF(K(I,1).EQ.41) THEN
59370 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
59375 C...Sum up energy-momentum in each junction string.
59382 DO 390 I1=NBEG,NEND
59383 IF(K(I1,2).NE.21) THEN
59388 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
59391 C...Find which of them has highest energy (minus mass) in rest frame.
59393 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
59395 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
59398 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
59399 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
59401 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
59402 C...Decide how to rearrange so that new last has highest energy.
59403 IF(PJU(1,6).LT.PJU(2,6)) THEN
59405 IRNG(1,2)=IJUR(2)-1
59407 IRNG(2,2)=IJUR(3)+1
59408 IRNG(4,1)=IJUR(3)-1
59412 IRNG(1,2)=IJUR(3)+1
59414 IRNG(2,2)=IJUR(3)-1
59415 IRNG(4,1)=IJUR(2)-1
59420 C...Copy in correct order below bottom of current event record.
59423 DO 430 I1=IRNG(II,1),IRNG(II,2),
59424 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
59426 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
59428 & '(PYPREP:) no more memory left in PYJETS')
59438 IF(K(I2,1).EQ.1) K(I2,1)=2
59442 C...Copy back up, overwriting but now in correct order.
59443 DO 460 I1=NBEG,NEND
59457 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
59458 C...to two q-qbar systems.
59459 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
59460 IF (MSTJ(19).NE.1) THEN
59464 C...Force collapse when MSTJ(19)=2.
59465 IF (MSTJ(19).EQ.2) THEN
59469 C...Find systems with exactly two junctions.
59471 C...Count junctions
59472 IF (K(I,1).EQ.41) THEN
59474 C...Check for interjunction gluons
59475 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
59478 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
59479 C...If end of system reached with either zero or one junction, restart
59480 C...with next system.
59484 ELSEIF(K(I,1).EQ.1) THEN
59485 C...If end of system reached with exactly two junctions, compute string
59486 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
59487 C...length measure for the (q-qbar)(q-qbar) topology.
59489 C...Loop down through chain.
59491 DO 480 I1=NBEG,NEND
59492 C...Store string piece division locations in event record
59493 IF (K(I1,2).NE.21) THEN
59498 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
59500 IF (PYR(0).LT.0.5D0) ISW=1
59501 C...Randomly choose which qqbar string gets the jj gluons.
59503 IF (PYR(0).GT.0.5D0) IGS=2
59504 C...Only compute string lengths when no topology forced.
59505 IF (MSTJ(19).EQ.0) THEN
59506 C...Repeat following for each junction
59508 C...Initialize iterative procedure for finding JRF
59514 C...Start iteration. Sum up momenta in string pieces
59516 C...JD=-1 for first junction, +1 for second junction.
59517 C...Find out where piece starts and ends and which direction to go.
59520 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
59521 IB = IJCP((IJU-1)*7 - JD*IJS)
59522 ELSEIF (IJS.EQ.3) THEN
59524 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
59525 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
59527 C...Initialize junction pull 4-vector.
59531 C...Initialize weight
59534 C...Sum up (weighted) momenta along each string piece
59535 DO 530 ISP=IA,IB,JD
59536 C...If present parton not last in chain
59537 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
59538 C...If last parton was a junction, store present weight
59539 IF (K(ISP-JD,2).EQ.88) THEN
59541 C...If last parton was a quark, reset to stored weight.
59542 ELSEIF (K(ISP-JD,2).NE.21) THEN
59546 C...Skip next parton if weight already large
59547 IF (PWT.GT.10D0) GOTO 530
59548 C...Compute momentum in TJUOLD frame:
59549 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
59551 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
59553 TMP=P(ISP,J)+TJUOLD(J)*BFC
59554 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
59557 TMP=TJUOLD(4)*P(ISP,4)+TDP
59558 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
59560 PWT=PWT+TMP/PARJ(48)
59561 C...Put |p| rather than m in 5th slot
59562 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
59569 C...Combine new boost (T) with old boost (TJUOLD)
59570 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
59572 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
59575 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
59577 C...If last boost small, accept JRF, else iterate.
59578 C...Also prevent possibility of infinite loop.
59579 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
59580 & IJRFIT.LT.MSTJ(18))THEN
59582 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
59583 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
59585 C...Store final boost, with change of sign since TJJ motion vector.
59587 TJJ(IJU,IX)=-TJUOLD(IX)
59589 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
59592 C...String length measure for (q-qbar)(q-qbar) topology.
59593 C...Note only momenta of nearest partons used (since rest of system
59595 IF (JJGLUE.EQ.0) THEN
59596 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
59597 & -1,IJCP(5-ISW)+1)
59599 C...Put jj gluons on selected string (IGS selected randomly above).
59601 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
59602 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
59604 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
59605 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
59609 C...String length measure for q-q-j-j-q-q topology.
59618 C...Note only momenta of nearest partons used (since rest of system
59621 IF (IX.EQ.4) ISGN=1
59622 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
59623 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
59624 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
59625 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
59626 IF (JJGLUE.EQ.0) THEN
59627 C...Junction motion vector dot product gives length when inter-junction
59629 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
59631 C...Junction motion vector dot products with gluon momenta give length
59632 C...when inter-junction gluons present.
59633 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
59634 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
59637 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
59638 IF (JJGLUE.EQ.0) THEN
59639 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
59641 DELMJJ=DELMJJ*4D0*T1G1*T2G2
59644 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
59645 C...(Always the case for MSTJ(19)=2 due to initialization above)
59646 IF (DELMJJ.GT.DELMQQ) THEN
59647 C...Put new system at end of event record
59650 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
59653 P(NCOP,IX)=P(ICOP,IX)
59654 K(NCOP,IX)=K(ICOP,IX)
59657 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
59658 C...Insert inter-junction gluon string piece (reversed)
59660 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
59664 P(NCOP,IX)=P(ICOP,IX)
59665 K(NCOP,IX)=K(ICOP,IX)
59670 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
59673 P(NCOP,IX)=P(ICOP,IX)
59674 K(NCOP,IX)=K(ICOP,IX)
59679 C...Copy system back in right order
59680 DO 670 ICOP=NBEG,NEND-2
59682 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
59683 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
59686 C...Shift down rest of event record
59687 DO 690 ICOP=NEND+1,N
59689 P(ICOP-2,IX)=P(ICOP,IX)
59690 K(ICOP-2,IX)=K(ICOP,IX)
59693 C...Update length of event record.
59703 C...Done if no checks on small-mass systems.
59704 IF(MSTJ(14).LT.0) RETURN
59705 IF(MSTJ(14).EQ.0) GOTO 1140
59707 C...Find lowest-mass colour singlet jet system.
59712 DO 770 I=MAX(1,IP),N
59713 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
59714 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
59721 DPS(5)=PYMASS(K(I,2))
59722 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
59724 DPS(J)=DPS(J)+P(I,J)
59727 DPS(5)=DPS(5)+PYMASS(K(I,2))
59728 ELSEIF(K(I,1).EQ.2) THEN
59730 DPS(J)=DPS(J)+P(I,J)
59732 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
59734 DPS(J)=DPS(J)+P(I,J)
59737 DPS(5)=DPS(5)+PYMASS(K(I,2))
59738 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
59740 IF(PD.LT.PDMIN) THEN
59754 C...Done if lowest-mass system above threshold for string frag.
59755 IF(PDMIN.GE.PARJ(32)) GOTO 1140
59757 C...Fill small-mass system as cluster.
59759 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
59769 C...Set up history, assuming cluster -> 2 hadrons.
59775 IF(MSTU(16).NE.2) THEN
59790 C...Find total flavour content - complicated by presence of junctions.
59794 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
59797 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
59801 C...If several diquarks, split up one to give even number of flavours.
59802 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
59804 IF(IABS(KFQ(3)).LT.1000) I1=1
59805 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
59806 KFQ(I1)=KFQ(I1)/1000
59811 C...If four quark ends, join two to diquark.
59812 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
59815 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
59816 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
59817 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
59818 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
59819 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
59820 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
59826 C...If two quark ends, plus quark or diquark, join quarks to diquark.
59830 IF(IABS(KFQ(I1)).GT.1000) I1=3
59831 IF(IABS(KFQ(I2)).GT.1000) I2=3
59832 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
59833 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
59834 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
59835 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
59841 C...Form two particles from flavours of lowest-mass system, if feasible.
59843 790 NTRY = NTRY + 1
59845 C...Open string with two specified endpoint flavours.
59849 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
59850 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
59851 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
59852 IF(KQ1+KQ2.NE.0) GOTO 1140
59853 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
59855 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
59857 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
59858 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
59859 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
59861 C...Open string with four specified flavours.
59862 ELSEIF(NQ.EQ.4) THEN
59867 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
59868 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
59869 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
59870 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
59871 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
59872 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
59873 C...Combine flavours pairwise to form two hadrons.
59876 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
59877 & IABS(KFQ(2)).GT.1000)) I2=3
59878 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
59879 & IABS(KFQ(3)).GT.1000))) I2=4
59883 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
59884 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
59885 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
59889 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
59890 C...No room for popcorn mesons in closed string -> 2 hadrons.
59892 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
59893 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
59894 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
59895 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
59897 P(N+2,5)=PYMASS(K(N+2,2))
59898 P(N+3,5)=PYMASS(K(N+3,2))
59900 C...If it does not work: try again (a number of times), give up (if no
59901 C...place to shuffle momentum or too many flavours), or form one hadron.
59902 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
59903 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
59905 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
59912 C...Perform two-particle decay of jet system.
59913 C...First step: find reference axis in decaying system rest frame.
59914 C...(Borrow slot N+2 for temporary direction.)
59918 DO 850 I=IC1+1,IC2-1
59919 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
59920 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
59921 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
59923 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
59927 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
59929 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
59930 PHI1=PYANGL(P(N+2,1),P(N+2,2))
59932 C...Second step: generate isotropic/anisotropic decay.
59933 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
59934 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
59936 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
59937 PT2=(1D0-UE(3)**2)*PA**2
59938 IF(MSTJ(16).LE.0) THEN
59941 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
59942 PR1=P(N+2,5)**2+PT2
59943 PR2=P(N+3,5)**2+PT2
59944 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
59946 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
59947 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
59949 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
59951 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
59952 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
59957 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
59958 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
59960 C...Third step: move back to event frame and set production vertex.
59961 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
59971 C...Else form one particle, if possible.
59979 C...Select hadron flavour from available quark flavours.
59980 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
59982 ELSEIF(NQ.EQ.2) THEN
59983 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
59985 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
59986 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
59988 IF(K(N+2,2).EQ.0) GOTO 910
59989 P(N+2,5)=PYMASS(K(N+2,2))
59991 C...Use old algorithm for E/p conservation? (EN)
59992 IF (MSTJ(16).LE.0) GOTO 1080
59994 C...Find the string piece closest to the cluster by a loop
59995 C...over the undecayed partons not in present cluster. (EN)
60000 DO 940 I1=MAX(1,IP),N-1
60001 IF(K(I1,1).EQ.1) NJUNC=0
60002 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
60003 IF(K(I1,1).EQ.41) GOTO 940
60004 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
60006 ELSEIF(K(I1,1).EQ.2) THEN
60010 IF(K(I2,1).EQ.41) GOTO 940
60011 IF(K(I2,1).GT.10) GOTO 920
60012 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
60013 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
60014 & NJUNC.EQ.0) GOTO 940
60015 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
60016 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
60017 & K(I2,1).NE.1)) GOTO 940
60019 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
60021 E1(J)=P(I1,J)/P(I1,4)
60022 E2(J)=P(I2,J)/P(I2,4)
60023 ECL(J)=P(N+1,J)/P(N+1,4)
60028 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
60029 E3S=E3(1)**2+E3(2)**2+E3(3)**2
60030 E4S=E4(1)**2+E4(2)**2+E4(3)**2
60031 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
60032 IF(E34.LE.0D0) THEN
60034 ELSEIF(E34.LT.E3S) THEN
60035 DDMIN=E4S-E34**2/E3S
60037 DDMIN=E4S-2D0*E34+E3S
60040 C...Is this the smallest so far?
60041 IF(DDMIN.LT.DGLOMI) THEN
60046 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
60051 C... Check if there are any strings to connect to the new gluon. (EN)
60052 IF (IBEG.EQ.0) GOTO 1080
60054 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
60055 IF (P(N+1,5).GE.P(N+2,5)) THEN
60057 C...Construct 'gluon' that is needed to put hadron on the mass shell.
60058 FRAC=P(N+2,5)/P(N+1,5)
60060 P(N+2,J)=FRAC*P(N+1,J)
60061 PG(J)=(1D0-FRAC)*P(N+1,J)
60064 C... Copy string with new gluon put in.
60068 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
60069 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
60090 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
60093 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
60094 C...from string piece endpoints.
60097 C...Begin by copying string that should give energy to cluster.
60101 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
60102 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
60114 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
60117 C...Set initial Phad.
60119 P(NSAV+2,J)=P(NSAV+1,J)
60122 C...Calculate Pg, a part of which will be added to Phad later. (EN)
60123 1020 IF(MSTJ(16).EQ.1) THEN
60127 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
60128 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
60131 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
60133 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
60135 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
60136 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
60138 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
60139 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
60140 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
60142 C...If all gluon energy eaten, zero it and take a step back.
60144 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
60147 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
60153 IF(K(I1,1).EQ.41) ITER=-1
60155 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
60158 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
60164 IF(K(I2,1).EQ.41) ITER=-1
60166 IF(ITER.EQ.1) GOTO 1020
60168 C...If also all endpoint energy eaten, revert to old procedure.
60169 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
60170 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
60181 C... Construct the collapsed hadron and modified string partons.
60183 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
60184 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
60185 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
60187 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
60188 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
60190 C...Finished with string collapse in new scheme.
60194 C... Use old algorithm; by choice or when in trouble.
60196 C...Find parton/particle which combines to largest extra mass.
60201 IF(IR.NE.0) GOTO 1100
60202 DO 1090 I=MAX(1,IP),N
60203 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
60204 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
60205 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
60206 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
60207 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
60208 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
60210 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
60211 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
60212 IF(HSR.GT.HSM) THEN
60220 C...Shuffle energy and momentum to put new particle on mass shell.
60225 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
60226 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
60227 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
60229 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
60230 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
60234 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
60238 C...Mark collapsed system and store daughter pointers. Iterate.
60239 1120 DO 1130 I=IC1,IC2
60240 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
60241 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
60243 IF(MSTU(16).NE.2) THEN
60248 K(I,5)=NSAV+1+NBODY
60251 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
60253 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
60255 C...Check flavours and invariant masses in parton systems.
60263 DO 1180 I=MAX(1,IP),N
60264 IF(K(I,1).EQ.41) NJU=NJU+1
60265 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
60267 IF(KC.EQ.0) GOTO 1180
60268 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60269 IF(KQ.EQ.0) GOTO 1180
60275 DPS(5)=DPS(5)+PYMASS(K(I,2))
60278 DPS(J)=DPS(J)+P(I,J)
60280 IF(K(I,1).EQ.1) THEN
60282 IF(NJU.EQ.0.AND.NP.NE.1) THEN
60283 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
60284 ELSEIF(NJU.EQ.1) THEN
60285 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
60286 ELSEIF(NJU.EQ.2) THEN
60287 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
60288 ELSEIF(NJU.GE.3) THEN
60291 IF(NFERR.EQ.1) THEN
60292 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
60296 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
60297 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
60298 & '(PYPREP:) too small mass in jet system')
60312 C*********************************************************************
60315 C...Handles the fragmentation of an arbitrary colour singlet
60316 C...jet system according to the Lund string fragmentation model.
60318 SUBROUTINE PYSTRF(IP)
60320 C...Double precision and integer declarations.
60321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60322 IMPLICIT INTEGER(I-N)
60323 INTEGER PYK,PYCHGE,PYCOMP
60325 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60326 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60327 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60328 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60329 C...Local arrays. All MOPS variables ends with MO
60330 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
60331 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
60332 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
60333 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
60334 &PBST(3,5),TJUOLD(5)
60336 C...Function: four-product of two vectors.
60337 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)
60338 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
60341 C...Reset counters.
60356 C...Identify parton system.
60359 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
60360 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
60361 IF(MSTU(21).GE.1) RETURN
60363 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
60365 IF(KC.EQ.0) GOTO 110
60366 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60367 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
60368 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
60369 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
60370 IF(MSTU(21).GE.1) RETURN
60373 C...Take copy of partons to be considered. Check flavour sum.
60378 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
60380 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
60382 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60383 IF(K(I,1).EQ.41) THEN
60384 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
60392 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
60393 IF(MOD(KQSUM,3).NE.0) THEN
60394 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
60395 IF(MSTU(21).GE.1) RETURN
60397 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
60399 C...Boost copied system to CM frame (for better numerical precision).
60400 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
60403 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
60407 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
60409 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
60410 IF(P(I,3).GT.0D0) THEN
60411 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
60412 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
60413 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
60415 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
60416 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
60417 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
60422 C...Search for very nearby partons that may be recombined.
60431 IF(MJU(1).GT.0) NRMIN=NRMIN+2
60432 IF(MJU(2).GT.0) NRMIN=NRMIN+2
60433 140 IF(NR.GT.NRMIN) THEN
60436 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
60438 IF(I.EQ.N+NR) I1=N+1
60439 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
60440 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
60442 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
60444 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
60445 & P(I1,2)**2+P(I1,3)**2))
60446 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
60447 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
60448 IF(PDR.LT.PDRMIN) THEN
60454 C...Recombine very nearby partons to avoid machine precision problems.
60455 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
60457 P(N+1,J)=P(N+1,J)+P(N+NR,J)
60459 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60463 ELSEIF(PDRMIN.LT.PARU12) THEN
60465 P(IR,J)=P(IR,J)+P(IR+1,J)
60467 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
60469 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
60470 DO 190 I=IR+1,N+NR-1
60477 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
60479 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
60480 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
60486 C...Reset particle counter. Skip ahead if no junctions are present;
60487 C...this is usually the case!
60488 NRS=MAX(5*NR+11,NP)
60491 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
60495 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
60496 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
60497 IF(MSTU(21).GE.1) RETURN
60501 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
60502 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
60503 & ' junction strings not handled by MSTJ(12)>3 options')
60506 IF(MJU(JT).EQ.0) GOTO 640
60510 C...Find and sum up momentum on three sides of junction.
60511 C...Begin with previous boost = zero.
60518 C...Beginning and end of string system in event record.
60519 I1BEG=N+1+(JT-1)*(NR-1)
60520 I1END=N+NR+(JT-1)*(1-NR)
60521 C...Look for junction string piece end points
60522 DO 230 I1=I1BEG,I1END,JS
60523 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
60524 C...Store junction string piece end points.
60525 C 1-junction systems 2-junction systems
60526 C IU : 1 2 3 4 1 2 3 4 5 6
60527 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
60531 C...Sum over momenta, from junction outwards.
60535 C...Initialize junction drag and string piece 4-vectors.
60540 C...First two branches. Inwards out means opposite direction to JS.
60541 C...(JS is 1 for JT=1, -1 for JT=2)
60546 C...Last branch (gq or gjgqgq). Direction now reversed.
60552 DO 270 I1=I1A,I1B,IDIR
60553 C...Sum up momentum directions with exponential suppression
60554 C...for use in finding junction rest frame below.
60555 IF (K(I1,2).EQ.88) THEN
60556 C...gjgqgq type system encountered. Use current PWT as start
60557 C...for both strings.
60560 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
60561 C...Sum up string piece (boosted) 4-momenta.
60563 PJU(IU,J)=PJU(IU,J)+P(I1,J)
60565 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
60566 C...boost is zero, see above). Skip parton if suppression factor large.
60567 IF (PWT.GT.10D0) GOTO 270
60568 C...Compute momentum in current frame:
60569 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
60570 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
60572 PTMP=P(I1,J)+TJUOLD(J)*BFC
60573 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
60576 PTMP=TJUOLD(4)*P(I1,4)+TDP
60577 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
60578 PWT=PWT+PTMP/PARJ(48)
60581 C...Put |p| rather than m in 5th slot.
60582 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
60583 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
60586 C...Calculate boost from present frame to next JRF candidate.
60588 CALL PYJURF(PBST,TJU)
60590 C...After some iterations do not take full step in new direction.
60591 IF(IJRFIT.GT.5) THEN
60592 REDUCE=0.8D0**(IJRFIT-5)
60593 TJU(1)=REDUCE*TJU(1)
60594 TJU(2)=REDUCE*TJU(2)
60595 TJU(3)=REDUCE*TJU(3)
60596 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
60599 C...Combine new boost (TJU) with old boost (TJUOLD)
60600 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
60602 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
60604 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
60606 C...If last boost small, accept JRF, else iterate.
60607 C...Also prevent possibility of infinite loop.
60608 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
60609 & IJRFIT.LT.MSTJ(18)) THEN
60611 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
60612 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
60615 C...Now store total boost in TJU and change perception.
60616 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
60617 C...TJU = junction motion vector in string CM, so the sign changes.
60621 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
60625 C...Calculate string piece energies in junction rest frame.
60627 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
60629 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
60630 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
60633 C...Start preparing for fragmentation of two strings from junction.
60636 320 NTRYER=NTRYER+1
60639 NS=IABS(IJU(IU+1)-IJU(IU))
60641 C...Junction strings: find longitudinal string directions.
60643 IS1=IJU(IU)+JS*(IS-1)
60646 DP(1,J)=0.5D0*P(IS1,J)
60647 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
60648 DP(2,J)=0.5D0*P(IS2,J)
60649 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
60650 & (PJU(IU,5)/PBST(IU,5))
60652 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
60653 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
60657 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
60658 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60659 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60664 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
60665 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
60666 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
60668 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
60670 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
60671 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
60675 C...Junction strings: initialize flavour, momentum and starting pos.
60679 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
60683 ELSEIF(NTRY.GT.100) THEN
60684 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
60685 IF(MSTU(21).GE.1) RETURN
60690 IE(1)=K(N+1+(JT/2)*(NP-1),3)
60691 IF (MOD(JT+IU,2).NE.0) THEN
60693 IF (NP-NR.NE.0) THEN
60694 C...If gluons have disappeared. Original IJU must be used.
60698 IF (K(IT,2).NE.21) THEN
60701 IF (NE.EQ.IU+4*(JT-1)) THEN
60703 ELSEIF (IT.LE.IP+NP) THEN
60706 CALL PYERRM(14,'(PYSTRF:) '//
60707 & 'Original IJU could not be reconstructed!')
60715 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
60721 KFL(1)=K(IJU(IU),2)
60729 C...Junction strings: find initial transverse directions.
60732 DP(2,J)=P(IN(4)+1,J)
60736 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60737 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60738 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
60739 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
60740 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
60741 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
60742 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
60743 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
60744 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
60746 DHCX1=DFOUR(3,1)/DHC12
60747 DHCX2=DFOUR(3,2)/DHC12
60748 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
60749 DHCY1=DFOUR(4,1)/DHC12
60750 DHCY2=DFOUR(4,2)/DHC12
60751 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
60752 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
60754 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
60756 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
60760 C...Junction strings: produce new particle, origin.
60762 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
60763 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
60764 IF(MSTU(21).GE.1) RETURN
60772 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
60773 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
60774 IF(K(I,2).EQ.0) GOTO 360
60775 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
60776 & IABS(KFL(3)).GT.10) THEN
60777 IF(PYR(0).GT.PARJ(19)) GOTO 440
60779 P(I,5)=PYMASS(K(I,2))
60780 CALL PYPTDI(KFL(1),PX(3),PY(3))
60781 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
60782 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
60783 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
60784 & MSTU(90).LT.8) THEN
60785 MSTU(90)=MSTU(90)+1
60786 MSTU(90+MSTU(90))=I
60787 PARU(90+MSTU(90))=Z
60789 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
60794 C...Junction strings: stepping within 'low' string region.
60795 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
60796 & P(IN(1),5)**2.GE.PR(1)) THEN
60797 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
60798 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
60800 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
60803 C...Has used up energy of junction string, i.e. no more hadrons in it.
60804 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
60809 C...Stepping from 'low' string region
60810 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
60811 P(IN(2)+2,4)=P(IN(2)+2,3)
60814 IF(IN(2).GT.N+NR+4*NS) GOTO 360
60815 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
60816 P(IN(1)+2,4)=P(IN(1)+2,3)
60822 C...Junction strings: find new transverse directions.
60823 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
60824 & IN(1).GT.IN(2)) GOTO 360
60825 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
60832 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60833 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60835 IF(DHC12.LE.1D-2) THEN
60836 P(IN(1)+2,4)=P(IN(1)+2,3)
60842 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
60843 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
60844 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
60845 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
60846 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
60847 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
60848 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
60849 DHCX1=DFOUR(3,1)/DHC12
60850 DHCX2=DFOUR(3,2)/DHC12
60851 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
60852 DHCY1=DFOUR(4,1)/DHC12
60853 DHCY2=DFOUR(4,2)/DHC12
60854 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
60855 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
60857 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
60859 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
60862 C...Express pT with respect to new axes, if sensible.
60863 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
60864 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
60865 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
60871 C...Junction strings: sum up known four-momentum, coefficients for m2.
60874 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
60875 & PY(3)*P(IN(3)+1,J)
60876 DO 510 IN1=IN(4),IN(1)-4,4
60877 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
60879 DO 520 IN2=IN(5),IN(2)-4,4
60880 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
60884 DHM(2)=2D0*FOUR(I,IN(1))
60885 DHM(3)=2D0*FOUR(I,IN(2))
60886 DHM(4)=2D0*FOUR(IN(1),IN(2))
60888 C...Junction strings: find coefficients for Gamma expression.
60889 DO 550 IN2=IN(1)+1,IN(2),4
60890 DO 540 IN1=IN(1),IN2-1,4
60891 DHC=2D0*FOUR(IN1,IN2)
60892 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
60893 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
60894 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
60895 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
60899 C...Junction strings: solve (m2, Gamma) equation system for energies.
60900 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
60901 IF(ABS(DHS1).LT.1D-4) GOTO 360
60902 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
60903 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
60904 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
60905 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
60906 & ABS(DHS1)-DHS2/DHS1)
60907 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
60908 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
60909 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
60911 C...Junction strings: step to new region if necessary.
60912 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
60913 P(IN(2)+2,4)=P(IN(2)+2,3)
60916 IF(IN(2).GT.N+NR+4*NS) GOTO 360
60917 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
60918 P(IN(1)+2,4)=P(IN(1)+2,3)
60923 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
60924 P(IN(1)+2,4)=P(IN(1)+2,3)
60930 C...Junction strings: particle four-momentum, remainder, loop back.
60932 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
60933 & P(IN(2)+2,4)*P(IN(2),J)
60934 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
60936 IF(P(I,4).LT.P(I,5)) GOTO 360
60937 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
60938 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
60939 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
60944 IF(IN(3).NE.IN(6)) THEN
60946 P(IN(6),J)=P(IN(3),J)
60947 P(IN(6)+1,J)=P(IN(3)+1,J)
60952 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
60953 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
60958 C...Junction strings: save quantities left after each string.
60959 IF(IABS(KFL(1)).GT.10) GOTO 360
60963 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
60966 C...Junction strings: loopback if much unused energy in both strings.
60967 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
60968 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
60969 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
60971 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
60972 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
60973 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
60974 & .AND.NTRYER.LT.10) GOTO 320
60976 C...Junction strings: put together to new effective string endpoint.
60978 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
60979 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
60980 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
60981 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
60983 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
60984 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
60986 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
60991 C...Open versus closed strings. Choose breakup region for latter.
60992 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
60995 ELSEIF(MJU(1).NE.0) THEN
60998 ELSEIF(MJU(2).NE.0) THEN
61001 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
61008 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
61009 W2SUM=W2SUM+P(N+NR+IS,1)
61014 W2SUM=W2SUM-P(N+NR+NB,1)
61015 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
61018 C...Find longitudinal string directions (i.e. lightlike four-vectors).
61020 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
61021 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
61024 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
61025 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
61027 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
61028 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
61030 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
61031 & DP(1,2)**2-DP(1,3)**2))
61032 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
61033 & DP(2,2)**2-DP(2,3)**2))
61037 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
61038 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
61039 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
61040 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
61042 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
61044 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
61045 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
61049 C...Begin initialization: sum up energy, set starting position.
61053 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61057 ELSEIF(NTRY.GT.100) THEN
61058 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61059 IF(MSTU(21).GE.1) RETURN
61066 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
61071 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
61072 IF(NS.GT.NR) IRANK(JT)=1
61074 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
61075 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
61076 IN(3*JT+2)=IN(3*JT+1)+1
61077 IN(3*JT+3)=N+NR+4*NS+2*JT-1
61078 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
61085 C.. MOPS variables and switches
61091 C...Initialize flavour and pT variables for open string.
61095 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
61099 KFL(JT)=K(IE(JT),2)
61100 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
61101 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
61103 PMQ(JT)=PYMASS(KFL(JT))
61107 C...Closed string: random initial breakup flavour, pT and vertex.
61109 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
61111 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
61112 C.. Closed string: first vertex diq attempt => enforced second
61114 IF(IABS(KFL(1)).GT.10)THEN
61119 IF(IBMO.EQ.1) MSTU(121)=-1
61121 CALL PYPTDI(KFL(1),PX(1),PY(1))
61124 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
61125 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
61126 ZR=PR3/(Z*P(N+NR+1,5)**2)
61127 IF(ZR.GE.1D0) GOTO 780
61130 PMQ(JT)=PYMASS(KFL(JT))
61131 GAM(JT)=PR3*(1D0-Z)/Z
61132 IN1=N+NR+3+4*(JT/2)*(NS-1)
61135 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
61138 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
61144 PM2QMO(JT)=PMQ(JT)**2
61145 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
61148 C...Find initial transverse directions (i.e. spacelike four-vectors).
61150 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
61159 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
61160 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
61161 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
61162 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
61163 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
61164 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
61165 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
61166 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
61167 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
61169 DHCX1=DFOUR(3,1)/DHC12
61170 DHCX2=DFOUR(3,2)/DHC12
61171 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
61172 DHCY1=DFOUR(4,1)/DHC12
61173 DHCY2=DFOUR(4,2)/DHC12
61174 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
61175 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
61177 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
61179 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
61184 P(IN3+2,J)=P(IN3,J)
61185 P(IN3+3,J)=P(IN3+1,J)
61190 C...Remove energy used up in junction string fragmentation.
61191 IF(MJU(1)+MJU(2).GT.0) THEN
61193 IF(NJS(JT).EQ.0) GOTO 860
61195 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
61199 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
61200 WMIN=PARJST+PMQ(1)+PMQ(2)
61201 WREM2=FOUR(N+NRS,N+NRS)
61202 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
61204 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
61209 C...Produce new particle: side, origin.
61211 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
61212 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61213 IF(MSTU(21).GE.1) RETURN
61215 C.. New side priority for popcorn systems
61216 IF(MSTU(121).LE.0)THEN
61218 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
61219 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
61223 IRANK(JT)=IRANK(JT)+1
61228 C...Generate flavour, hadron and pT.
61230 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
61231 IF(K(I,2).EQ.0) GOTO 710
61233 IF(MSTU(121).EQ.-1) GOTO 910
61234 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
61235 &IABS(KFL(3)).GT.10) THEN
61236 IF(PYR(0).GT.PARJ(19)) GOTO 880
61238 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61240 P(I,5)=PYMASS(K(I,2))
61241 CALL PYPTDI(KFL(JT),PX(3),PY(3))
61242 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
61244 C...Final hadrons for small invariant mass.
61246 PMQ(3)=PYMASS(KFL(3))
61248 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
61249 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
61250 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
61251 &WMIN-0.5D0*PARJ(36)*PMQ(3)
61252 WREM2=FOUR(N+NRS,N+NRS)
61253 IF(WREM2.LT.0.10D0) GOTO 710
61254 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
61255 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
61257 C...Choose z, which gives Gamma. Shift z for heavy flavours.
61258 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
61259 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
61260 &MSTU(90).LT.8) THEN
61261 MSTU(90)=MSTU(90)+1
61262 MSTU(90+MSTU(90))=I
61263 PARU(90+MSTU(90))=Z
61267 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
61268 &MOD(KFL2A/1000,10)).GE.4) THEN
61269 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61270 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
61271 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
61272 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61273 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
61275 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
61277 C.. MOPS baryon model modification
61278 XTMO3=(1D0-Z)*XTMO(JT)
61279 IF(IABS(KFL(3)).LE.10) NRVMO=0
61280 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
61284 IF(IABS(KFL(JT)).LE.10)THEN
61285 XBMO=MIN(XTMO3,1D0-(2D-10))
61288 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
61289 GTSTMO=1D0-PARF(192)**PGMO
61291 IF(IRANK(JT).EQ.1) THEN
61296 IF(XBMO.LT.1D0-(1D-10))THEN
61297 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
61298 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
61301 IF(MSTJ(12).GE.5)THEN
61302 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
61303 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
61304 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
61309 C.. MOPS Accepting popcorn system hadron.
61310 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
61311 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
61313 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
61315 & '(PYSTRF:) no more memory left in PYJETS')
61316 IF(MSTU(21).GE.1) RETURN
61328 DO 890 LINE=1,I-N-NR
61329 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
61330 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
61337 C..Reject popcorn system, flag=-1 if enforcing new one
61339 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
61344 C..Lift restoring string outside MOPS block
61345 910 IF(MSTU(121).LT.0) THEN
61346 IF(MSTU(121).EQ.-2) MSTU(121)=0
61349 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
61360 DO 920 LINE=1,I-N-NR
61361 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
61362 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
61370 C.. MOPS end of modification
61376 C...Stepping within or from 'low' string region easy.
61377 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
61378 &P(IN(1),5)**2.GE.PR(JT)) THEN
61379 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
61380 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
61382 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
61385 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
61386 P(IN(JR)+2,4)=P(IN(JR)+2,3)
61389 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
61390 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
61391 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61397 C...Find new transverse directions (i.e. spacelike string vectors).
61398 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
61399 &IN(1).GT.IN(2)) GOTO 710
61400 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
61407 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
61408 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
61410 IF(DHC12.LE.1D-2) THEN
61411 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61417 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
61418 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
61419 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
61420 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
61421 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
61422 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
61423 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
61424 DHCX1=DFOUR(3,1)/DHC12
61425 DHCX2=DFOUR(3,2)/DHC12
61426 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
61427 DHCY1=DFOUR(4,1)/DHC12
61428 DHCY2=DFOUR(4,2)/DHC12
61429 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
61430 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
61432 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
61434 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
61437 C...Express pT with respect to new axes, if sensible.
61438 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
61439 & FOUR(IN(3*JT+3)+1,IN(3)))
61440 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
61441 & FOUR(IN(3*JT+3)+1,IN(3)+1))
61442 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
61448 C...Sum up known four-momentum. Gives coefficients for m2 expression.
61451 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
61452 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
61453 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
61454 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
61456 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
61457 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
61461 DHM(2)=2D0*FOUR(I,IN(1))
61462 DHM(3)=2D0*FOUR(I,IN(2))
61463 DHM(4)=2D0*FOUR(IN(1),IN(2))
61465 C...Find coefficients for Gamma expression.
61466 DO 1030 IN2=IN(1)+1,IN(2),4
61467 DO 1020 IN1=IN(1),IN2-1,4
61468 DHC=2D0*FOUR(IN1,IN2)
61469 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
61470 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
61471 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
61472 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
61476 C...Solve (m2, Gamma) equation system for energies taken.
61477 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
61478 IF(ABS(DHS1).LT.1D-4) GOTO 710
61479 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
61480 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
61481 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
61482 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
61483 &ABS(DHS1)-DHS2/DHS1)
61484 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
61485 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
61486 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
61488 C...Step to new region if necessary.
61489 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
61490 P(IN(JR)+2,4)=P(IN(JR)+2,3)
61493 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
61494 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
61495 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61500 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
61501 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61507 C...Four-momentum of particle. Remaining quantities. Loop back.
61509 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
61510 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
61512 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
61513 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
61515 IF(P(I,4).LT.P(I,5)) GOTO 710
61521 IF(IN(3).NE.IN(3*JT+3)) THEN
61523 P(IN(3*JT+3),J)=P(IN(3),J)
61524 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
61529 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
61530 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
61532 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61536 C...Final hadron: side, flavour, hadron, mass.
61542 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
61543 IF(K(I,2).EQ.0) GOTO 710
61544 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
61546 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61548 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61550 P(I,5)=PYMASS(K(I,2))
61551 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61553 C...Final two hadrons: find common setup of four-vectors.
61555 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
61556 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
61557 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
61558 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
61559 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
61560 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
61561 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
61562 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
61563 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
61564 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
61567 C...Solve kinematics for final two hadrons, if possible.
61568 WREM2=2D0*DHR1*DHR2*DHC12
61569 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
61570 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
61571 IF(FD.GE.1D0) GOTO 710
61572 FA=WREM2+PR(JT)-PR(JR)
61573 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
61575 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61576 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
61577 FB=SIGN(FB,JS*(PYR(0)-PREV))
61580 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
61581 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
61582 &4D0*WREM2*PR(JT))),DBLE(JS))
61584 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
61585 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
61586 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
61587 P(I,J)=P(N+NRS,J)-P(I-1,J)
61589 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
61590 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
61591 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
61592 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
61594 IF(NTRYFN.LT.100) GOTO 140
61595 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
61598 C...Mark jets as fragmented and give daughter pointers.
61600 DO 1100 I=NSAV+1,NSAV+NP
61603 IF(MSTU(16).NE.2) THEN
61612 C...Document string system. Move up particles.
61623 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
61627 K(I,J)=K(I+NRS-1,J)
61628 P(I,J)=P(I+NRS-1,J)
61633 DO 1140 IZ=MSTU90+1,MSTU91
61634 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
61635 PARU9T(IZ)=PARU(90+IZ)
61639 C...Order particles in rank along the chain. Update mother pointer.
61642 K(I-NSAV+N,J)=K(I,J)
61643 P(I-NSAV+N,J)=P(I,J)
61647 DO 1190 I=N+1,2*N-NSAV
61648 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
61654 IF(MSTU(16).NE.2) K(I1,3)=NSAV
61655 DO 1180 IZ=MSTU90+1,MSTU91
61656 IF(MSTU9T(IZ).EQ.I) THEN
61657 MSTU(90)=MSTU(90)+1
61658 MSTU(90+MSTU(90))=I1
61659 PARU(90+MSTU(90))=PARU9T(IZ)
61663 DO 1220 I=2*N-NSAV,N+1,-1
61664 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
61670 IF(MSTU(16).NE.2) K(I1,3)=NSAV
61671 DO 1210 IZ=MSTU90+1,MSTU91
61672 IF(MSTU9T(IZ).EQ.I) THEN
61673 MSTU(90)=MSTU(90)+1
61674 MSTU(90+MSTU(90))=I1
61675 PARU(90+MSTU(90))=PARU9T(IZ)
61680 C...Boost back particle system. Set production vertices.
61683 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
61687 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61688 IF(P(I,3).GT.0D0) THEN
61689 HHPEZ=(P(I,4)+P(I,3))*HHBZ
61690 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61691 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61693 HHPEZ=(P(I,4)-P(I,3))/HHBZ
61694 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61695 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61708 C*********************************************************************
61711 C...From three given input vectors in PJU the boost VJU from
61712 C...the "lab frame" to the junction rest frame is constructed.
61714 SUBROUTINE PYJURF(PJU,VJU)
61716 C...Double precision and integer declarations.
61717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61718 IMPLICIT INTEGER(I-N)
61720 C...Input, output and local arrays.
61721 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
61722 DATA TWOPI/6.283186D0/
61724 C...Calculate masses and other invariants.
61726 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
61728 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
61729 PSUM(5)=SQRT(PSUM2)
61732 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
61733 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
61737 C...Pick I to be most massive parton and J to be the one closest to I.
61740 IF(A(2,2).GT.A(1,1)) I=2
61741 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
61745 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
61756 C...Trivial find new parton energies if all three partons are massless.
61757 IF(PMI2.LT.1D-4) THEN
61758 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
61759 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
61760 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
61762 C...Else find momentum range for parton I and values at extremes.
61768 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
61769 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
61770 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
61771 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
61772 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
61773 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
61774 HI=PEIMAX**2-0.25D0*PAIMAX**2
61775 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
61776 & 0.5D0*PAIMAX*AIJ)/HI
61777 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
61778 & 0.5D0*PAIMAX*AIK)/HI
61779 PEJMAX=SQRT(PAJMAX**2+PMJ2)
61780 PEKMAX=SQRT(PAKMAX**2+PMK2)
61781 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
61783 C...If unexpected values at upper endpoint then pick another parton.
61784 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
61786 IF(A(I1,I1).GE.1D-4) THEN
61792 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
61798 C..Start binary + linear search to find solution inside range.
61802 PAI=0.5D0*(PAIMIN+PAIMAX)
61805 C...Derive momentum of other two partons and distance to root.
61806 PEI=SQRT(PAI**2+PMI2)
61807 HI=PEI**2-0.25D0*PAI**2
61808 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
61809 PEJ=SQRT(PAJ**2+PMJ2)
61810 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
61811 PEK=SQRT(PAK**2+PMK2)
61812 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
61814 C...Pick next I momentum to explore, hopefully closer to root.
61815 IF(FNOW.GT.0D0) THEN
61824 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
61826 PAI=0.5D0*(PAIMIN+PAIMAX)
61828 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
61829 & ABS(FNOW).GT.1D-12*PSUM2) THEN
61830 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
61835 C...Now know energies in junction rest frame.
61840 C...Boost (copy of) partons to their rest frame.
61841 VXCM=-PSUM(1)/PSUM(5)
61842 VYCM=-PSUM(2)/PSUM(5)
61843 VZCM=-PSUM(3)/PSUM(5)
61844 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
61846 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
61847 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
61848 PCM(I,1)=PJU(I,1)+FAC2*VXCM
61849 PCM(I,2)=PJU(I,2)+FAC2*VYCM
61850 PCM(I,3)=PJU(I,3)+FAC2*VZCM
61851 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
61852 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
61855 C...Construct difference vectors and boost to junction rest frame.
61857 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
61858 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
61860 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
61861 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
61862 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
61863 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
61864 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
61865 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
61866 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
61867 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
61868 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
61869 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
61870 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
61872 C...Add two boosts, giving final result.
61873 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
61874 VJU(1)=VXJU+FCM*VXCM
61875 VJU(2)=VYJU+FCM*VYCM
61876 VJU(3)=VZJU+FCM*VZCM
61877 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
61880 C...In case of error in reconstruction: revert to CM frame of system.
61881 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
61882 &(PCM(1,5)*PCM(2,5))
61883 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
61884 &(PCM(1,5)*PCM(3,5))
61885 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
61886 &(PCM(2,5)*PCM(3,5))
61887 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
61888 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
61890 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
61891 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
61892 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
61893 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
61894 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
61895 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
61896 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
61898 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
61899 &(PCM(1,5)*PCM(2,5))
61900 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
61901 &(PCM(1,5)*PCM(3,5))
61902 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
61903 &(PCM(2,5)*PCM(3,5))
61904 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
61905 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
61906 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
61916 C*********************************************************************
61919 C...Handles the fragmentation of a jet system (or a single
61920 C...jet) according to independent fragmentation models.
61922 SUBROUTINE PYINDF(IP)
61924 C...Double precision and integer declarations.
61925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61926 IMPLICIT INTEGER(I-N)
61927 INTEGER PYK,PYCHGE,PYCOMP
61929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61932 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61934 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
61935 &KFLO(2),PXO(2),PYO(2),WO(2)
61937 C.. MOPS error message
61938 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
61939 &' are not treated as expected in independent fragmentation')
61941 C...Reset counters. Identify parton system and take copy. Check flavour.
61951 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61952 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
61953 IF(MSTU(21).GE.1) RETURN
61955 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
61957 IF(KC.EQ.0) GOTO 110
61958 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61959 IF(KQ.EQ.0) GOTO 110
61961 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61963 K(NSAV+NJET,J)=K(I,J)
61964 P(NSAV+NJET,J)=P(I,J)
61965 DPS(J)=DPS(J)+P(I,J)
61968 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
61969 &K(I+1,1).EQ.2)) GOTO 110
61970 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
61971 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
61972 IF(MSTU(21).GE.1) RETURN
61975 C...Boost copied system to CM frame. Find CM energy and sum flavours.
61978 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
61979 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
61985 DO 140 I=NSAV+1,NSAV+NJET
61989 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
61990 ELSEIF(KFA.GT.1000) THEN
61991 KFLA=MOD(KFA/1000,10)
61992 KFLB=MOD(KFA/100,10)
61993 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
61994 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
61998 C...Loop over attempts made. Reset counters.
62001 IF(NTRY.GT.200) THEN
62002 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
62003 IF(MSTU(21).GE.1) RETURN
62013 C...Loop over jets to be fragmented.
62014 DO 230 IP1=NSAV+1,NSAV+NJET
62019 C...Initial flavour and momentum values. Jet along +z axis.
62020 KFLH=IABS(K(IP1,2))
62021 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
62023 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
62025 C...Initial values for quark or diquark jet.
62026 170 IF(IABS(K(IP1,2)).NE.21) THEN
62029 CALL PYPTDI(0,PXO(1),PYO(1))
62032 C...Initial values for gluon treated like random quark jet.
62033 ELSEIF(MSTJ(2).LE.2) THEN
62035 IF(MSTJ(2).EQ.2) MSTJ(91)=1
62036 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62037 CALL PYPTDI(0,PXO(1),PYO(1))
62040 C...Initial values for gluon treated like quark-antiquark jet pair,
62041 C...sharing energy according to Altarelli-Parisi splitting function.
62044 IF(MSTJ(2).EQ.4) MSTJ(91)=1
62045 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62047 CALL PYPTDI(0,PXO(1),PYO(1))
62050 WO(1)=WF*PYR(0)**(1D0/3D0)
62054 C...Initial values for rank, flavour, pT and W+.
62064 C...New hadron. Generate flavour and hadron species.
62066 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
62067 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
62068 IF(MSTU(21).GE.1) RETURN
62075 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
62076 IF(K(I,2).EQ.0) GOTO 180
62077 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
62078 IF(PYR(0).GT.PARJ(19)) GOTO 200
62081 C...Find hadron mass. Generate four-momentum.
62082 P(I,5)=PYMASS(K(I,2))
62083 CALL PYPTDI(KFL1,PX2,PY2)
62086 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
62087 CALL PYZDIS(KFL1,KFL2,PR,Z)
62089 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
62091 MSTU(90)=MSTU(90)+1
62092 MSTU(90+MSTU(90))=I
62093 PARU(90+MSTU(90))=Z
62095 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
62096 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
62097 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
62098 & P(I,3).LE.0.001D0) THEN
62099 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
62105 C...Remaining flavour and momentum.
62114 C...Check if pL acceptable. Go back for new hadron if enough energy.
62115 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
62117 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
62119 IF(W.GT.PARJ(31)) GOTO 190
62122 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
62123 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
62125 C...Rotate jet to new direction.
62126 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
62127 PHI=PYANGL(P(IP1,1),P(IP1,2))
62129 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
62130 K(K(IP1,3),4)=NSAV1+1
62133 C...End of jet generation loop. Skip conservation in some cases.
62135 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
62136 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
62138 C...Subtract off produced hadron flavours, finished if zero.
62139 DO 240 I=NSAV+NJET+1,N
62141 KFLA=MOD(KFA/1000,10)
62142 KFLB=MOD(KFA/100,10)
62143 KFLC=MOD(KFA/10,10)
62145 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
62146 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
62148 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
62149 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
62150 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
62153 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62154 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62155 IF(NREQ.EQ.0) GOTO 320
62157 C...Take away flavour of low-momentum particles until enough freedom.
62161 DO 260 I=NSAV+NJET+1,N
62162 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
62163 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
62164 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
62166 IF(IREM.EQ.0) GOTO 150
62168 KFA=IABS(K(IREM,2))
62169 KFLA=MOD(KFA/1000,10)
62170 KFLB=MOD(KFA/100,10)
62171 KFLC=MOD(KFA/10,10)
62172 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
62173 IF(K(IREM,1).EQ.8) GOTO 250
62175 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
62176 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
62177 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
62179 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
62180 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
62181 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
62184 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62185 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62186 IF(NREQ.GT.NREM) GOTO 250
62187 DO 270 I=NSAV+NJET+1,N
62188 IF(K(I,1).EQ.8) K(I,1)=1
62191 C...Find combination of existing and new flavours for hadron.
62193 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
62194 IF(NREQ.LT.NREM) NFET=1
62195 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
62197 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
62198 KFLF(J)=ISIGN(1,NFL(1))
62199 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
62200 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
62202 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
62204 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
62205 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
62206 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
62207 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
62208 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
62209 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
62210 IF(NFET.LE.2) KFLF(3)=0
62211 IF(KFLF(3).NE.0) THEN
62212 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
62213 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
62214 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
62215 & KFLFC=KFLFC+ISIGN(2,KFLFC)
62219 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
62220 IF(KF.EQ.0) GOTO 280
62221 DO 300 J=1,MAX(2,NFET)
62222 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
62225 C...Store hadron at random among free positions.
62226 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
62227 DO 310 I=NSAV+NJET+1,N
62228 IF(K(I,1).EQ.7) NPOS=NPOS-1
62229 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
62232 P(I,5)=PYMASS(K(I,2))
62233 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62236 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62237 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62238 IF(NREM.GT.0) GOTO 280
62240 C...Compensate for missing momentum in global scheme (3 options).
62241 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
62244 DO 330 I=NSAV+NJET+1,N
62245 PSI(J)=PSI(J)+P(I,J)
62248 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
62250 DO 350 I=NSAV+NJET+1,N
62251 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
62252 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
62253 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
62254 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
62256 DO 370 I=NSAV+NJET+1,N
62257 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
62258 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
62259 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
62260 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
62262 P(I,J)=P(I,J)-PSI(J)*PW/PWS
62264 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62267 C...Compensate for missing momentum withing each jet separately.
62268 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
62269 DO 390 I=N+1,N+NJET
62275 DO 410 I=NSAV+NJET+1,N
62278 K(IR2,1)=K(IR2,1)+1
62279 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
62280 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
62282 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
62284 P(IR2,4)=P(IR2,4)+P(I,4)
62285 P(IR2,5)=P(IR2,5)+PLS
62288 DO 420 I=N+1,N+NJET
62289 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
62291 DO 440 I=NSAV+NJET+1,N
62294 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
62295 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
62297 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
62300 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62304 C...Scale momenta for energy conservation.
62305 IF(MOD(MSTJ(3),5).NE.0) THEN
62309 DO 450 I=NSAV+NJET+1,N
62312 PQS=PQS+P(I,5)**2/P(I,4)
62314 IF(PMS.GE.PECM) GOTO 150
62317 PFAC=(PECM-PQS)/(PES-PQS)
62320 DO 480 I=NSAV+NJET+1,N
62324 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62326 PQS=PQS+P(I,5)**2/P(I,4)
62328 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
62331 C...Origin of produced particles and parton daughter pointers.
62332 490 DO 500 I=NSAV+NJET+1,N
62333 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
62334 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
62336 DO 510 I=NSAV+1,NSAV+NJET
62339 IF(MSTU(16).NE.2) THEN
62343 K(I1,4)=K(I1,4)-NJET+1
62344 K(I1,5)=K(I1,5)-NJET+1
62345 IF(K(I1,5).LT.K(I1,4)) THEN
62352 C...Document independent fragmentation system. Remove copy of jets.
62363 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
62365 DO 540 I=NSAV+NJET,N
62367 K(I-NJET+1,J)=K(I,J)
62368 P(I-NJET+1,J)=P(I,J)
62369 V(I-NJET+1,J)=V(I,J)
62373 DO 550 IZ=MSTU90+1,MSTU(90)
62374 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
62377 C...Boost back particle system. Set production vertices.
62378 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
62379 &DPS(2)/DPS(4),DPS(3)/DPS(4))
62389 C*********************************************************************
62392 C...Handles the decay of unstable particles.
62394 SUBROUTINE PYDECY(IP)
62396 C...Double precision and integer declarations.
62397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62398 IMPLICIT INTEGER(I-N)
62399 INTEGER PYK,PYCHGE,PYCOMP
62401 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62404 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62405 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
62407 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
62408 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
62410 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
62412 C...Functions: momentum in two-particle decays and four-product.
62413 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
62414 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)
62416 C...Initial values.
62420 KFS=ISIGN(1,K(IP,2))
62424 C...Choose lifetime and determine decay vertex.
62425 IF(K(IP,1).EQ.5) THEN
62427 ELSEIF(K(IP,1).NE.4) THEN
62428 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
62431 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
62434 C...Determine whether decay allowed or not.
62436 IF(MSTJ(22).EQ.2) THEN
62437 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
62438 ELSEIF(MSTJ(22).EQ.3) THEN
62439 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
62440 ELSEIF(MSTJ(22).EQ.4) THEN
62441 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
62442 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
62444 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
62449 C...Interface to external tau decay library (for tau polarization).
62450 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
62452 C...Starting values for pointers and momenta.
62456 PCMTAU(J)=P(ITAU,J)
62459 C...Iterate to find position and code of mother of tau.
62461 120 IMTAU=K(IMTAU,3)
62463 IF(IMTAU.EQ.0) THEN
62464 C...If no known origin then impossible to do anything further.
62468 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
62469 C...If tau -> tau + gamma then add gamma energy and loop.
62470 IF(K(K(IMTAU,4),2).EQ.22) THEN
62472 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
62474 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
62476 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
62481 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
62482 C...If coming from weak decay of hadron then W is not stored in record,
62483 C...but can be reconstructed by adding neutrino momentum.
62484 KFORIG=-ISIGN(24,K(ITAU,2))
62486 DO 160 II=K(IMTAU,4),K(IMTAU,5)
62487 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
62489 PCMTAU(J)=PCMTAU(J)+P(II,J)
62495 C...If coming from resonance decay then find latest copy of this
62496 C...resonance (may not completely agree).
62499 DO 170 II=IMTAU+1,IP-1
62500 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
62501 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
62504 PCMTAU(J)=P(IORIG,J)
62508 C...Boost tau to rest frame of production process (where known)
62509 C...and rotate it to sit along +z axis.
62511 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
62513 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
62514 & -DBETAU(2),-DBETAU(3))
62515 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
62516 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
62517 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
62518 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
62520 C...Call tau decay routine (if meaningful) and fill extra info.
62521 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
62522 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
62523 DO 200 II=NSAV+1,NSAV+NDECAY
62532 C...Boost back decay tau and decay products.
62536 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
62537 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
62538 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
62539 & DBETAU(2),DBETAU(3))
62541 C...Skip past ordinary tau decay treatment.
62549 C...B-Bbar mixing: flip sign of meson appropriately.
62551 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
62553 IF(KFA.EQ.531) XBBMIX=PARJ(77)
62554 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
62555 IF(MMIX.EQ.1) KFS=-KFS
62558 C...Check existence of decay channels. Particle/antiparticle rules.
62560 IF(MDCY(KC,2).GT.0) THEN
62561 MDMDCY=MDME(MDCY(KC,2),2)
62562 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
62564 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
62565 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
62568 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
62569 IF(KCHG(KC,3).EQ.0) THEN
62572 IF(PYR(0).GT.0.5D0) KFS=-KFS
62573 ELSEIF(KFS.GT.0) THEN
62581 C...Sum branching ratios of allowed decay channels.
62584 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
62585 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
62586 & KFSN*MDME(IDL,1).NE.3) GOTO 230
62587 IF(MDME(IDL,2).GT.100) GOTO 230
62589 BRSU=BRSU+BRAT(IDL)
62592 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
62596 C...Select decay channel among allowed ones.
62597 240 RBR=BRSU*PYR(0)
62600 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
62601 &KFSN*MDME(IDL,1).NE.3) THEN
62602 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
62603 ELSEIF(MDME(IDL,2).GT.100) THEN
62604 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
62608 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
62611 C...Start readout of decay channel: matrix element, reset counters.
62614 IF(MOD(NTRY,200).EQ.0) THEN
62615 WRITE(CIDC,'(I4)') IDC
62616 C...Do not print warning for some well-known special cases.
62617 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
62618 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
62622 IF(NTRY.GT.1000) THEN
62623 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
62624 IF(MSTU(21).GE.1) RETURN
62630 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
62633 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
62635 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
62641 IF(KFA.GT.80) MHADDY=1
62642 C.. Random flavour and popcorn system memory.
62648 C...Read out decay products. Convert to standard flavour code.
62650 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
62652 IF(JT.LE.5) KP=KFDP(IDC,JT)
62653 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
62654 IF(KP.EQ.0) GOTO 280
62657 IF(KPA.GT.80) MHADDY=1
62658 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
62660 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
62662 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
62663 KFP=-KFS*MOD(KFA/10,10)
62664 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
62665 KFP=KFS*(100*MOD(KFA/10,100)+3)
62666 ELSEIF(KPA.EQ.81) THEN
62667 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
62668 ELSEIF(KP.EQ.82) THEN
62669 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
62670 IF(KFP.EQ.0) GOTO 260
62674 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
62675 ELSEIF(KP.EQ.-82) THEN
62678 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
62680 C...Add decay product to event record or to quark flavour list.
62683 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
62686 C...set rndmflav popcorn system pointer
62687 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
62689 PSQ=PSQ+PYMASS(KFLO(NQ))
62690 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
62691 & MOD(NQ,2).EQ.1) THEN
62696 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
62697 IF(K(I,2).EQ.0) GOTO 260
62699 P(I,5)=PYMASS(K(I,2))
62704 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
62705 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
62707 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
62708 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
62718 C...Check masses for resonance decays.
62719 IF(MHADDY.EQ.0) THEN
62720 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
62723 C...Choose decay multiplicity in phase space model.
62724 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
62726 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
62727 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
62729 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
62730 IF(IRNDMO.EQ.0) THEN
62733 ELSEIF(IRNDMO.EQ.1) THEN
62738 IF(NTRY.GT.1000) THEN
62739 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
62740 IF(MSTU(21).GE.1) RETURN
62742 IF(MMAT.LE.20) THEN
62743 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
62744 & SIN(PARU(2)*PYR(0))
62745 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
62746 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
62747 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
62748 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
62749 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
62753 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
62755 IF(MSTU(121).GT.MSTU(125)) GOTO 300
62757 C...Form hadrons from flavour content.
62761 IF(ND.EQ.NP+NQ/2) GOTO 330
62762 DO 320 I=N+NP+1,N+ND-NQ/2
62763 C.. Stick to started popcorn system, else pick side at random
62765 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
62766 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
62767 IF(K(I,2).EQ.0) GOTO 300
62768 MSTU(125)=MSTU(125)-1
62770 IF(MSTU(121).GT.0) JTMO=JT
62776 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
62777 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
62778 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
62781 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
62782 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
62783 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
62784 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
62786 C...Check that sum of decay product masses not too large.
62788 DO 340 I=N+NP+1,N+ND
62793 P(I,5)=PYMASS(K(I,2))
62796 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
62798 C...Rescale energy to subtract off spectator quark mass.
62799 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
62800 & .AND.NP.GE.3) THEN
62802 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
62804 P(N+NP,J)=PQT*PV(1,J)
62805 PV(1,J)=(1D0-PQT)*PV(1,J)
62807 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
62811 C...Fully specified final state: check mass broadening effects.
62813 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
62817 C...Determine position of grandmother, number of sisters.
62823 IF(IM.LT.0.OR.IM.GE.IP) IM=0
62824 IF(IM.NE.0) KFAM=IABS(K(IM,2))
62826 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
62827 IF(K(IL,3).EQ.IM) NM=NM+1
62828 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
62830 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
62831 & MOD(KFAM/1000,10).NE.0) NM=0
62833 KFAS=IABS(K(ISIS,2))
62834 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
62835 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
62840 C...Kinematics of one-particle decays.
62848 C...Calculate maximum weight ND-particle decay.
62851 WTMAX=1D0/WTCOR(ND-2)
62852 PMAX=PV(1,5)-PS+P(N+ND,5)
62854 DO 380 IL=ND-1,1,-1
62855 PMAX=PMAX+P(N+IL,5)
62856 PMIN=PMIN+P(N+IL+1,5)
62857 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
62861 C...Find virtual gamma mass in Dalitz decay.
62862 390 IF(ND.EQ.2) THEN
62863 ELSEIF(MMAT.EQ.2) THEN
62864 PMES=4D0*PMAS(11,1)**2
62865 PMRHO2=PMAS(131,1)**2
62866 PGRHO2=PMAS(131,2)**2
62867 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
62868 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
62869 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
62870 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
62871 IF(WT.LT.PYR(0)) GOTO 400
62872 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
62874 C...M-generator gives weight. If rejected, try again.
62879 DO 420 IL2=IL1-1,1,-1
62880 IF(RSAV.LE.RORD(IL2)) GOTO 430
62881 RORD(IL2+1)=RORD(IL2)
62883 430 RORD(IL2+1)=RSAV
62887 DO 450 IL=ND-1,1,-1
62888 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
62890 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
62892 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
62895 C...Perform two-particle decays in respective CM frame.
62896 460 DO 480 IL=1,ND-1
62897 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
62898 UE(3)=2D0*PYR(0)-1D0
62900 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
62901 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
62904 PV(IL+1,J)=-PA*UE(J)
62906 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
62907 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
62910 C...Lorentz transform decay products to lab frame.
62914 DO 530 IL=ND-1,1,-1
62916 BE(J)=PV(IL,J)/PV(IL,4)
62918 GA=PV(IL,4)/PV(IL,5)
62920 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
62922 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
62924 P(I,4)=GA*(P(I,4)+BEP)
62928 C...Check that no infinite loop in matrix element weight.
62930 IF(NTRY.GT.800) GOTO 560
62932 C...Matrix elements for omega and phi decays.
62934 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
62935 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
62936 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
62937 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
62939 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
62940 ELSEIF(MMAT.EQ.2) THEN
62941 FOUR12=FOUR(N+1,N+2)
62942 FOUR13=FOUR(N+1,N+3)
62943 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
62944 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
62945 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
62947 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
62948 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
62949 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
62950 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
62952 FOUR12=FOUR(IP,N+1)
62953 FOUR02=FOUR(IM,N+1)
62957 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
62958 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
62959 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
62960 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
62961 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
62962 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
62964 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
62965 ELSEIF(MMAT.EQ.4) THEN
62966 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
62967 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
62968 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
62969 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
62970 & ((1D0-HX3)/(HX1*HX2))**2
62971 IF(WT.LT.2D0*PYR(0)) GOTO 390
62972 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
62975 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
62976 ELSEIF(MMAT.EQ.41) THEN
62977 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
62978 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
62979 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
62980 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
62982 C...Matrix elements for weak decays (only semileptonic for c and b)
62983 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
62984 & .AND.ND.EQ.3) THEN
62985 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
62986 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
62987 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
62988 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
62992 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
62995 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
62996 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
62997 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
63000 C...Scale back energy and reattach spectator.
63001 560 IF(MREM.EQ.1) THEN
63003 PV(1,J)=PV(1,J)/(1D0-PQT)
63009 C...Low invariant mass for system with spectator quark gives particle,
63010 C...not two jets. Readjust momenta accordingly.
63011 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
63013 PM2=PYMASS(K(N+2,2))
63015 PM3=PYMASS(K(N+3,2))
63016 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
63017 & (PARJ(32)+PM2+PM3)**2) GOTO 630
63020 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
63021 IF(K(N+2,2).EQ.0) GOTO 260
63022 P(N+2,5)=PYMASS(K(N+2,2))
63023 PS=P(N+1,5)+P(N+2,5)
63028 ELSEIF(MMAT.EQ.44) THEN
63030 PM3=PYMASS(K(N+3,2))
63032 PM4=PYMASS(K(N+4,2))
63033 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
63034 & (PARJ(32)+PM3+PM4)**2) GOTO 600
63037 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
63038 IF(K(N+3,2).EQ.0) GOTO 260
63039 P(N+3,5)=PYMASS(K(N+3,2))
63041 P(N+3,J)=P(N+3,J)+P(N+4,J)
63043 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)
63044 HA=P(N+1,4)**2-P(N+2,4)**2
63045 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
63046 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
63047 & (P(N+1,3)-P(N+2,3))**2
63048 HD=(PV(1,4)-P(N+3,4))**2
63049 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
63052 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
63054 PCOR=HH*(P(N+1,J)-P(N+2,J))
63055 P(N+1,J)=P(N+1,J)+PCOR
63056 P(N+2,J)=P(N+2,J)-PCOR
63058 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)
63059 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)
63063 C...Check invariant mass of W jets. May give one particle or start over.
63064 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
63065 &.AND.IABS(K(N+1,2)).LT.10) THEN
63066 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
63068 PM1=PYMASS(K(N+1,2))
63070 PM2=PYMASS(K(N+2,2))
63071 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
63072 KFLDUM=INT(1.5D0+PYR(0))
63073 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
63074 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
63075 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
63076 PSM=PYMASS(KF1)+PYMASS(KF2)
63077 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
63078 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
63079 IF(MMAT.EQ.48) GOTO 390
63080 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
63083 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
63084 IF(K(N+1,2).EQ.0) GOTO 260
63085 P(N+1,5)=PYMASS(K(N+1,2))
63088 PS=P(N+1,5)+P(N+2,5)
63089 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
63096 C...Phase space decay of partons from W decay.
63097 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
63103 PV(1,J)=P(N+1,J)+P(N+2,J)
63112 PSQ=PYMASS(KFLO(1))
63114 PSQ=PSQ+PYMASS(KFLO(2))
63119 C...Boost back for rapidly moving particle.
63123 BE(J)=P(IP,J)/P(IP,4)
63127 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
63129 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
63131 P(I,4)=GA*(P(I,4)+BEP)
63135 C...Fill in position of decay vertex.
63143 C...Set up for parton shower evolution from jets.
63144 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
63148 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
63149 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
63150 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
63151 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
63152 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
63153 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
63155 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
63158 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
63159 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
63160 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
63161 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
63163 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
63164 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
63167 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
63168 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
63169 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
63170 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
63172 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
63173 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
63175 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
63180 KCP=PYCOMP(K(NSAV+1,2))
63181 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
63183 IF(KQP.LT.0) JCON=5
63184 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
63185 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
63186 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
63187 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
63189 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
63192 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
63193 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
63194 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
63195 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
63199 C...Mark decayed particle; special option for B-Bbar mixing.
63200 IF(K(IP,1).EQ.5) K(IP,1)=15
63201 IF(K(IP,1).LE.10) K(IP,1)=11
63202 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
63210 C*********************************************************************
63213 C...Handles flavour production in the decay of unstable particles
63214 C...and small string clusters.
63216 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
63218 C...Double precision and integer declarations.
63219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63220 IMPLICIT INTEGER(I-N)
63221 INTEGER PYK,PYCHGE,PYCOMP
63223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63224 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63225 SAVE /PYDAT1/,/PYDAT2/
63228 C.. Call PYKFDI directly if no popcorn option is on
63229 IF(MSTJ(12).LT.2) THEN
63230 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
63237 IF(KFL1.EQ.0) RETURN
63242 NMAX=MIN(MSTU(125),10)
63244 C.. Identify rank 0 cluster qq
63246 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
63249 C.. Join jets: Fails if store not empty
63250 IF(MSTU(121).GT.0) THEN
63254 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
63255 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
63256 C.. Pick popcorn meson from store, return same qq, decrease store
63257 KF=MSTU(NSTO+MSTU(121))
63259 MSTU(121)=MSTU(121)-1
63261 C.. Generate new flavour. Then done if no diquark is generated
63262 100 CALL PYKFDI(KFL1,0,KFL3,KF)
63263 IF(MSTU(121).EQ.-1) GOTO 100
63265 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
63267 C.. Simple case if no dynamical popcorn suppressions are considered
63268 IF(MSTJ(12).LT.4) THEN
63269 IF(MSTU(121).EQ.0) RETURN
63272 CALL PYKFDI(KFPREV,0,KFL3,KFM)
63273 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
63274 IF(IABS(KFL3).LE.10)THEN
63281 C test output qq against fake Gamma, then return if no popcorn.
63284 CALL PYZDIS(1,2103,5D0,Z)
63286 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
63291 IF(MSTU(121).EQ.0) RETURN
63293 C..Set store size memory. Pick fake dynamical variables of qq.
63295 CALL PYPTDI(1,PX3,PY3)
63301 C.. Pick next popcorn meson, test with fake dynamical variables
63305 CALL PYKFDI(KFPREV,0,KFL3,KFM)
63306 IF(MSTU(121).EQ.-1) GOTO 100
63307 CALL PYPTDI(KFL3,PX3,PY3)
63308 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
63309 CALL PYZDIS(KFPREV,KFL3,PM,Z)
63316 IF(MSTJ(12).GT.4)THEN
63317 POPMN=SQRT((1D0-X)*(G/X-GB))
63318 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
63319 PTST=EXP((POPM-POPMN)*PARF(193))
63324 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
63327 IF(RTST.GT.PTST*GTST)THEN
63329 IF(RTST.GT.PTST) MSTU(121)=-1
63334 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
63335 IF(MSTU(121).GT.0) GOTO 110
63337 C.. Test accepted system size. If OK set global popcorn size variable.
63338 IF(NMES.GT.NMAX)THEN
63349 C********************************************************************
63352 C...Generates a new flavour pair and combines off a hadron
63354 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
63356 C...Double precision and integer declarations.
63357 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63358 IMPLICIT INTEGER(I-N)
63359 INTEGER PYK,PYCHGE,PYCOMP
63361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63363 SAVE /PYDAT1/,/PYDAT2/
63367 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
63369 C...Default flavour values. Input consistency checks.
63374 IF(KF1A.EQ.0) RETURN
63376 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
63377 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
63378 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
63381 C...Check if tabulated flavour probabilities are to be used.
63382 IF(MSTJ(15).EQ.1) THEN
63383 IF(MSTJ(12).GE.5) CALL PYERRM(29,
63384 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
63385 & ' together with MSTJ(12)>=5 modification')
63387 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
63388 KFL1A=MOD(KF1A/1000,10)
63389 KFL1B=MOD(KF1A/100,10)
63391 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
63392 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
63393 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
63394 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
63398 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
63399 KFL2A=MOD(KF2A/1000,10)
63400 KFL2B=MOD(KF2A/100,10)
63402 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
63403 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
63404 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
63406 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
63409 C.. Recognize rank 0 diquark case
63411 KFDIQ=MAX(KF1A,KF2A)
63412 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
63414 C.. Join two flavours to meson or baryon. Test for popcorn.
63417 IF(KFDIQ.GT.10) THEN
63418 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
63419 & CALL PYNMES(KFDIQ)
63420 IF(MSTU(121).NE.0) THEN
63431 C.. Separate incoming flavours, curtain flavour consistency check
63437 KFL1A=MOD(KF1A/1000,10)
63438 KFL1B=MOD(KF1A/100,10)
63441 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
63442 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
63443 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
63445 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
63449 KFQOLD=KFL1A+KFL1B-KFQPOP
63452 C...Meson/baryon choice. Set number of mesons if starting a popcorn
63455 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
63456 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
63460 ELSEIF(KF1A.GT.10)THEN
63462 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
63463 IF(MSTU(121).GT.0) MBARY=-1
63466 C..x->H+q: Choose single vertex quark. Jump to form hadron.
63467 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
63468 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
63469 KFL3=ISIGN(KFQVER,-KFIN)
63473 C..x->H+qq: (IDW=proper PARF position for diquark weights)
63476 IF(MSTU(121).EQ.0) IDW=150
63478 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
63479 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
63480 C.. Shift to s-curtain parameters if needed
63481 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
63482 PARF(194)=PARF(138)*PARF(139)
63483 PARF(193)=PARJ(8)+PARJ(9)
63487 C.. x->H+qq: Get vertex quark
63488 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
63490 MSTU(121)=MSTU(121)-1
63491 IF(IDW.EQ.170) THEN
63492 IF(MSTU(121).EQ.0)THEN
63493 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
63495 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
63498 IF(MSTU(121).EQ.0)THEN
63499 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
63501 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
63507 RMES=PYR(0)*PARF(194)
63509 RMES=RMES-PARF(IPOS+IMES)
63510 IF(IMES.EQ.30) THEN
63515 IF(RMES.GT.0D0) GOTO 120
63518 IF(KMUL.EQ.2) KFJ=10003
63519 IF(KMUL.EQ.3) KFJ=10001
63520 IF(KMUL.EQ.4) KFJ=20003
63521 IF(KMUL.EQ.5) KFJ=5
63523 KFQVER=MOD(IMES,5)+1
63524 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
63525 IF(KFQVER.GT.3)THEN
63530 IF(MBARY.EQ.-1) IDW=170
63532 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
63533 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
63534 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
63535 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
63537 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
63541 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
63543 IF(KFQPOP.NE.KFQVER)THEN
63545 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
63546 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
63547 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
63549 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
63551 KFL3=ISIGN(KFDIQ,KFIN)
63553 C..x->M+y: flavour for meson.
63554 130 IF(MBARY.LE.0)THEN
63555 KFLA=MAX(KFQOLD,KFQVER)
63556 KFLB=MIN(KFQOLD,KFQVER)
63558 IF(KFLA.NE.KFQOLD) KFS=-KFS
63559 C... Form meson, with spin and flavour mixing for diagonal states.
63560 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
63561 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
63562 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
63565 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
63566 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
63567 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
63568 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
63569 IF(PYR(0).LT.PARJ(14)) KMUL=2
63570 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
63572 IF(RMUL.LT.PARJ(15)) KMUL=3
63573 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
63574 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
63577 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
63578 IF(KMUL.EQ.5) KFLS=5
63579 IF(KFLA.NE.KFLB)THEN
63580 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
63583 IMIX=2*KFLA+10*KMUL
63584 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
63585 & INT(RMIX+PARF(IMIX)))+KFLS
63586 IF(KFLA.GE.4) KF=110*KFLA+KFLS
63588 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
63589 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
63591 C..Optional extra suppression of eta and eta'.
63592 C..Allow shift to qq->B+q in old version (set IRANK to 0)
63593 IF(KF.EQ.221.OR.KF.EQ.331)THEN
63594 IF(PYR(0).GT.PARJ(25+KF/300))THEN
63595 IF(KF2A.GT.0) GOTO 130
63596 IF(MSTJ(12).LT.4) IRANK=0
63602 C.. x->B+y: Flavour for baryon
63605 IF(KF1A.LE.10) KFLA=KFQOLD
63606 KFLB=MOD(KFDIQ/1000,10)
63607 KFLC=MOD(KFDIQ/100,10)
63608 KFLDS=MOD(KFDIQ,10)
63609 KFLD=MAX(KFLA,KFLB,KFLC)
63610 KFLF=MIN(KFLA,KFLB,KFLC)
63611 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
63613 C... SU(6) factors for formation of baryon.
63617 IF(KFLB.NE.KFLC)THEN
63620 IF(KFLB.GT.2) KDMAX=KDMAX+2
63622 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
63627 SU6MAX=PARF(140+KDMAX)
63630 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
63635 SU6OCT=PARF(60+KBARY)
63636 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
63637 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
63638 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
63640 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
63642 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
63644 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
63645 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
63647 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
63651 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
63654 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
63655 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
63657 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
63659 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
63660 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
63664 C...Use tabulated probabilities to select new flavour and hadron.
63665 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
63668 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
63671 ELSEIF(KTAB2.EQ.0) THEN
63680 DO 150 KT3=KT3L,KT3U
63681 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
63687 DO 170 KT3=KT3L,KT3U
63689 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
63690 IF(RFL.LE.0D0) GOTO 190
63695 C...Reconstruct flavour of produced quark/diquark.
63696 IF(KTAB3.LE.6) THEN
63699 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
63702 IF(KTAB3.GE.8) KFL3A=2
63703 IF(KTAB3.GE.11) KFL3A=3
63704 IF(KTAB3.GE.16) KFL3A=4
63705 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
63706 KFL3=1000*KFL3A+100*KFL3B+1
63707 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
63709 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
63712 C...Reconstruct meson code.
63713 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
63715 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
63716 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
63718 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
63719 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
63720 & 25*KTABS)) KF=330+2*KTABS+1
63721 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
63722 KFLA=MAX(KTAB1,KTAB3)
63723 KFLB=MIN(KTAB1,KTAB3)
63725 IF(KFLA.NE.KF1A) KFS=-KFS
63726 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
63727 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
63729 IF(KFL1A.EQ.KFL3A) THEN
63730 KFLA=MAX(KFL1B,KFL3B)
63731 KFLB=MIN(KFL1B,KFL3B)
63732 IF(KFLA.NE.KFL1B) KFS=-KFS
63733 ELSEIF(KFL1A.EQ.KFL3B) THEN
63737 ELSEIF(KFL1B.EQ.KFL3A) THEN
63740 ELSEIF(KFL1B.EQ.KFL3B) THEN
63741 KFLA=MAX(KFL1A,KFL3A)
63742 KFLB=MIN(KFL1A,KFL3A)
63743 IF(KFLA.NE.KFL1A) KFS=-KFS
63745 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
63748 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
63750 C...Reconstruct baryon code.
63752 IF(KTAB1.GE.7) THEN
63761 KFLD=MAX(KFLA,KFLB,KFLC)
63762 KFLF=MIN(KFLA,KFLB,KFLC)
63763 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
63764 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
63765 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
63768 C...Check that constructed flavour code is an allowed one.
63769 IF(KFL2.NE.0) KFL3=0
63772 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
63780 C*********************************************************************
63783 C...Generates number of popcorn mesons and stores some relevant
63786 SUBROUTINE PYNMES(KFDIQ)
63788 C...Double precision and integer declarations.
63789 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63790 IMPLICIT INTEGER(I-N)
63791 INTEGER PYK,PYCHGE,PYCOMP
63793 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63794 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63795 SAVE /PYDAT1/,/PYDAT2/
63798 IF(MSTJ(12).LT.2) RETURN
63800 C..Old version: Get 1 or 0 popcorn mesons
63801 IF(MSTJ(12).LT.5)THEN
63803 IF(KFDIQ.NE.0) THEN
63805 KFA=MOD(KFDIQA/1000,10)
63806 KFB=MOD(KFDIQA/100,10)
63809 IF(KFA.EQ.3) POPWT=PARF(133)
63810 IF(KFB.EQ.3) POPWT=PARF(134)
63811 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
63813 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
63817 C..New version: Store popcorn- or rank 0 diquark parameters
63820 PARF(194)=PARF(139)
63821 IF(KFDIQ.NE.0) THEN
63824 PARF(194)=PARF(140)
63826 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
63827 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
63828 & '(PYNMES:) Neglecting too large popcorn possibility')
63832 C..New version: Get number of popcorn mesons
63835 110 MSTU(121)=MSTU(121)+1
63836 RTST=RTST/PARF(194)
63837 IF(RTST.LT.1D0) GOTO 110
63838 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
63839 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
63843 C***************************************************************
63846 C...Precalculates a set of diquark and popcorn weights.
63850 C...Double precision and integer declarations.
63851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63852 IMPLICIT INTEGER(I-N)
63853 INTEGER PYK,PYCHGE,PYCOMP
63855 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63856 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63857 SAVE /PYDAT1/,/PYDAT2/
63859 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
63863 C..Diquark indices for dimensional variables
63872 C.. *** SU(6) factors **
63873 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
63875 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
63876 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
63877 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
63880 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
63882 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
63883 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
63885 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
63886 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
63889 C..SU(6)max q q' s,c,b
63890 SU6MUD =MAX(SU6(1) , SU6(8) )
63891 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
63892 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
63893 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
63894 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
63895 SU6M(IUS0)=SU6M(ISU0)
63896 SU6M(ISS1)=SU6M(IUU1)
63897 SU6M(IUS1)=SU6M(ISU1)
63899 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
63901 PARF(142)=SU6M(IUD1)
63902 PARF(143)=SU6M(ISU0)
63903 PARF(144)=SU6M(ISU1)
63904 PARF(145)=SU6M(ISS1)
63906 C..diquark SU(6) survival =
63907 C..sum over quark (quark tunnel weight)*(SU(6)).
63908 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
63909 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
63910 DMB(IUS0)=DMB(ISU0)
63911 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
63912 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
63913 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
63914 DMB(IUS1)=DMB(ISU1)
63915 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
63917 C.. *** Tunneling factors for Diquark production***
63918 C.. T: half a curtain pair = sqrt(curtain pair factor)
63919 IF(MSTJ(12).GE.5) THEN
63921 PMUD1=PYMASS(2103)-PMUD0
63922 PMUS0=PYMASS(3201)-PMUD0
63923 PMUS1=PYMASS(3203)-PMUS0-PMUD0
63924 PMSS1=PYMASS(3303)-PMUS0-PMUD0
63925 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
63926 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
63927 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
63928 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
63929 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
63930 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
63931 QBB(IUD1)=QBB(IUU1)
63933 PAR2M=SQRT(PARJ(2))
63934 PAR3M=SQRT(PARJ(3))
63935 PAR4M=SQRT(PARJ(4))
63936 QBB(ISU0)=PAR2M*PAR3M
63938 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
63940 QBB(ISU1)=PAR4M*QBB(ISU0)
63941 QBB(IUS1)=PAR4M*QBB(IUS0)
63945 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
63946 QBM(ISU0)=QBB(ISU0)
63947 QBM(IUS0)=PARJ(2)*QBB(IUS0)
63948 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
63949 QBM(IUU1)=6D0*QBB(IUU1)
63950 QBM(ISU1)=3D0*QBB(ISU1)
63951 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
63952 QBM(IUD1)=3D0*QBB(IUD1)
63954 C.. Combine T and tau to diquark weight for q-> B+B+..
63956 QBB(I)=QBB(I)*QBM(I)
63959 IF(MSTJ(12).GE.5)THEN
63960 C..New version: tau for rank 0 diquark.
63961 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
63962 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
63963 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
63964 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
63965 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
63966 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
63967 DMB(7+IUD1)=DMB(7+IUU1)/2D0
63969 C..New version: curtain flavour ratios.
63970 C.. s/u for q->B+M+...
63971 C.. s/u for rank 0 diquark: su -> ...M+B+...
63972 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
63973 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
63974 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
63975 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
63976 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
63977 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
63978 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
63980 C..Old version: reset unused rank 0 diquark weights and
63981 C.. unused diquark SU(6) survival weights
63983 IF(MSTJ(12).LT.3) DMB(I)=1D0
63987 C..Old version: Shuffle PARJ(7) into tau
63988 QBM(IUS0)=QBM(IUS0)*PARJ(7)
63989 QBM(ISS1)=QBM(ISS1)*PARJ(7)
63990 QBM(IUS1)=QBM(IUS1)*PARJ(7)
63992 C..Old version: curtain flavour ratios.
63993 C.. s/u for q->B+M+...
63994 C.. s/u for rank 0 diquark: su -> ...M+B+...
63995 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
63996 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
63997 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
63998 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
63999 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
64002 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
64003 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
64005 DMB(7+I)=DMB(7+I)*DMB(I)
64006 DMB(I)=DMB(I)*QBM(I)
64007 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
64008 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
64011 C.. *** Popcorn factors ***
64013 IF(MSTJ(12).LT.5)THEN
64014 C.. Old version: Resulting popcorn weights.
64016 WS=PARF(135)*PARF(138)
64018 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
64020 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
64021 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
64022 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
64023 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
64024 & (1D0+QBB(IUD1)+QBB(IUU1)+
64025 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
64027 C..New version: Store weights for popcorn mesons,
64028 C..get prel. popcorn weights.
64029 DO 150 IPOS=201,1400
64038 IF(MR.EQ.7) PARF(193)=PARJ(10)
64039 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
64040 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
64041 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
64043 IF(NMES.EQ.1) SQWT=PARJ(2)
64045 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
64046 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
64047 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
64049 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
64050 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
64053 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
64055 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
64056 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
64062 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
64063 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
64064 IF(PJWT.LE.0D0) GOTO 190
64065 IF(PJWT.GT.1D0) PJWT=1D0
64067 IMIX=2*KFQOLD+10*KMUL
64069 IF(KMUL.EQ.2) KFJ=10003
64070 IF(KMUL.EQ.3) KFJ=10001
64071 IF(KMUL.EQ.4) KFJ=20003
64072 IF(KMUL.EQ.5) KFJ=5
64074 KFLA=MAX(KFQOLD,KFQVER)
64075 KFLB=MIN(KFQOLD,KFQVER)
64076 SWT=PARJ(11+KFLA/3+KFLA/4)
64077 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
64079 QWT=SQWT/(2D0+SQWT)
64080 IF(KFQVER.LT.3)THEN
64081 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
64082 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
64084 IF(KFQVER.NE.KFQOLD)THEN
64086 KFM=100*KFLA+10*KFLB+KFJ
64087 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64088 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
64089 WTTOT=WTTOT+PARF(IPOS+IMES)
64092 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
64093 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
64094 IF(ID.EQ.5) DWT=PARF(IMIX)
64096 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64097 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
64098 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
64099 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
64100 PARF(IPOS+5*KMUL+ID)=
64101 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
64103 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
64109 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
64111 IF(MR.EQ.7) PARF(140)=
64112 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
64113 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
64114 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
64120 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
64125 C..Recombine diquark weights to flavour and spin ratios
64126 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
64127 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
64128 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
64129 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
64130 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
64131 PARF(155)=QBB(ISU1)/QBB(ISU0)
64132 PARF(156)=QBB(IUS1)/QBB(IUS0)
64133 PARF(157)=QBB(IUD1)
64135 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
64136 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
64137 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
64138 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
64139 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
64140 PARF(165)=QBM(ISU1)/QBM(ISU0)
64141 PARF(166)=QBM(IUS1)/QBM(IUS0)
64142 PARF(167)=QBM(IUD1)
64144 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
64145 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
64146 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
64147 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
64148 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
64149 PARF(175)=DMB(ISU1)/DMB(ISU0)
64150 PARF(176)=DMB(IUS1)/DMB(IUS0)
64151 PARF(177)=DMB(IUD1)
64153 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
64154 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
64155 PARF(187)=DMB(7+IUD1)
64161 C*********************************************************************
64164 C...Generates transverse momentum according to a Gaussian.
64166 SUBROUTINE PYPTDI(KFL,PX,PY)
64168 C...Double precision and integer declarations.
64169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64170 IMPLICIT INTEGER(I-N)
64171 INTEGER PYK,PYCHGE,PYCOMP
64173 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64176 C...Generate p_T and azimuthal angle, gives p_x and p_y.
64178 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
64179 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
64180 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
64181 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
64189 C*********************************************************************
64192 C...Generates the longitudinal splitting variable z.
64194 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
64196 C...Double precision and integer declarations.
64197 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64198 IMPLICIT INTEGER(I-N)
64199 INTEGER PYK,PYCHGE,PYCOMP
64201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64203 SAVE /PYDAT1/,/PYDAT2/
64205 C...Check if heavy flavour fragmentation.
64209 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
64211 C...Lund symmetric scaling function: determine parameters of shape.
64212 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
64213 &MSTJ(11).GE.4) THEN
64215 IF(MSTJ(91).EQ.1) FA=PARJ(43)
64216 IF(KFLB.GE.10) FA=FA+PARJ(45)
64218 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
64221 IF(KFLA.GE.10) FC=FC-PARJ(45)
64222 IF(KFLB.GE.10) FC=FC+PARJ(45)
64223 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
64225 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
64226 FC=FC+FRED*FBB*PARF(100+KFLH)**2
64229 IF(ABS(FC-1D0).GT.0.01D0) MC=2
64231 C...Determine position of maximum. Special cases for a = 0 or a = c.
64232 IF(FA.LT.0.02D0) THEN
64235 IF(FC.GT.FB) ZMAX=FB/FC
64236 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
64241 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
64242 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
64245 C...Subdivide z range if distribution very peaked near endpoint.
64247 IF(ZMAX.LT.0.1D0) THEN
64253 ZDIVC=ZDIV**(1D0-FC)
64254 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
64256 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
64258 FSCB=SQRT(4D0+(FC/FB)**2)
64259 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
64260 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
64261 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
64262 FINT=1D0+FB*(1D0-ZDIV)
64265 C...Choice of z, preweighted for peaks at low or high z.
64269 IF(FINT*PYR(0).LE.1D0) THEN
64271 ELSEIF(MC.EQ.1) THEN
64275 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
64278 ELSEIF(MMAX.EQ.3) THEN
64279 IF(FINT*PYR(0).LE.1D0) THEN
64281 FPRE=EXP(FB*(Z-ZDIV))
64283 Z=ZDIV+Z*(1D0-ZDIV)
64287 C...Weighting according to correct formula.
64288 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
64289 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
64290 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
64291 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
64292 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
64294 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
64296 FC=PARJ(50+MAX(1,KFLH))
64297 IF(MSTJ(91).EQ.1) FC=PARJ(59)
64299 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
64300 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
64301 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
64302 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
64305 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
64306 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
64313 C*********************************************************************
64316 C...Generates timelike parton showers from given partons.
64318 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
64320 C...Double precision and integer declarations.
64321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64322 IMPLICIT INTEGER(I-N)
64323 INTEGER PYK,PYCHGE,PYCOMP
64324 C...Parameter statement to help give large particle numbers.
64325 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
64326 &KEXCIT=4000000,KDIMEN=5000000)
64327 PARAMETER (MAXNUR=1000)
64329 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
64330 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64333 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
64334 COMMON/PYINT1/MINT(400),VINT(400)
64335 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
64337 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
64338 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
64339 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
64340 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
64343 C...Check that QMAX not too low.
64344 IF(MSTJ(41).LE.0) THEN
64346 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
64347 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
64349 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
64353 C...Store positions of shower initiating partons.
64355 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
64358 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
64363 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
64364 & .AND.IP2.GE.-80) THEN
64369 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
64377 & '(PYSHOW:) failed to reconstruct showering system')
64378 IF(MSTU(21).GE.1) RETURN
64381 C...Send off to PYPTFS for pT-ordered evolution if requested,
64382 C...if at least 2 partons, and without predefined shower branchings.
64383 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
64388 PTPART(II)=0.5D0*QMAX
64390 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
64394 C...Initialization of cutoff masses etc.
64402 PMTH(1,21)=PYMASS(21)
64403 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
64404 PMTH(3,21)=2D0*PMTH(2,21)
64405 PMTH(4,21)=PMTH(3,21)
64406 PMTH(5,21)=PMTH(3,21)
64407 PMTH(1,22)=PYMASS(22)
64408 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
64409 PMTH(3,22)=2D0*PMTH(2,22)
64410 PMTH(4,22)=PMTH(3,22)
64411 PMTH(5,22)=PMTH(3,22)
64413 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
64414 PMQT1E=MIN(PMQTH1,PARJ(90))
64416 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
64417 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
64420 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
64422 PMTH(1,IFL)=PYMASS(IFL)
64423 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
64424 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
64425 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
64426 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
64429 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
64430 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
64431 PMTH(1,IFL)=PYMASS(IFL)
64432 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
64433 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
64434 PMTH(4,IFL)=PMTH(3,IFL)
64435 PMTH(5,IFL)=PMTH(3,IFL)
64437 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
64439 ALFM=LOG(PT2MIN/ALAMS)
64441 C...Check on phase space available for emission.
64449 KFLA(I)=IABS(K(IPA(I),2))
64451 C...Special cutoff masses for initial partons (may be a heavy quark,
64452 C...squark, ..., and need not be on the mass shell).
64454 IF(NPA.LE.1) IREF(I)=IR
64455 IF(NPA.GE.2) IREF(I+1)=IR
64459 IF(KFLA(I).LE.8) THEN
64461 IF(MSTJ(41).GE.2) ISCHG(IR)=1
64462 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
64463 & KFLA(I).EQ.17) THEN
64464 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
64465 ELSEIF(KFLA(I).EQ.21) THEN
64467 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
64468 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
64470 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
64473 C...same for QQ~[3S18]
64474 ELSEIF(KFLA(I).EQ.9900443.OR.KFLA(I).EQ.9900553) THEN
64478 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
64480 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
64481 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
64482 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
64483 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
64484 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
64485 ELSEIF(ISCOL(IR).EQ.1) THEN
64486 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
64487 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
64488 PMTH(4,IR)=PMTH(3,IR)
64489 PMTH(5,IR)=PMTH(3,IR)
64490 ELSEIF(ISCHG(IR).EQ.1) THEN
64491 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
64492 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
64493 PMTH(4,IR)=PMTH(3,IR)
64494 PMTH(5,IR)=PMTH(3,IR)
64496 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
64498 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
64500 PS(J)=PS(J)+P(IPA(I),J)
64503 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
64504 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
64505 IF(NPA.EQ.1) PS(5)=PS(4)
64506 IF(PS(5).LE.PM+PMQT1E) RETURN
64508 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
64511 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
64512 KFSRCE=IABS(K(K(IP1,3),2))
64514 IPAR1=MAX(1,K(IP1,3))
64515 IPAR2=MAX(1,K(IP2,3))
64516 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
64517 & KFSRCE=IABS(K(K(IPAR1,3),2))
64520 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
64521 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
64522 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
64523 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
64524 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
64525 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
64526 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
64527 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
64529 C...Identify two primary showerers.
64531 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
64532 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
64533 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
64534 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
64535 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
64536 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
64537 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
64538 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
64540 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
64541 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
64542 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
64543 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
64544 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
64545 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
64546 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
64547 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
64549 C...Order of showerers. Presence of gluino.
64550 ITYPMN=MIN(ITYPE1,ITYPE2)
64551 ITYPMX=MAX(ITYPE1,ITYPE2)
64553 IF(ITYPE1.GT.ITYPE2) IORD=2
64555 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
64557 C...Check if 3-jet matrix elements to be used.
64560 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
64561 IF(MSTJ(38).NE.0) THEN
64565 ELSEIF(MSTJ(47).GE.6) THEN
64571 C...Vector/axial vector -> q + qbar; q -> q + V.
64572 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
64573 & ITYPES.EQ.3)) THEN
64575 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
64577 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
64578 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
64579 C...gamma*/Z0: assume e+e- initial state if unknown.
64581 IF(KFSRCE.EQ.23) THEN
64582 IANNFL=K(K(IP1,3),3)
64583 IF(IANNFL.NE.0) THEN
64584 KANNFL=IABS(K(IANNFL,2))
64585 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
64588 AI=SIGN(1D0,EI+0.1D0)
64589 VI=AI-4D0*EI*PARU(102)
64590 EF=KCHG(KFLA(1),1)/3D0
64591 AF=SIGN(1D0,EF+0.1D0)
64592 VF=AF-4D0*EF*PARU(102)
64593 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
64596 SQWZ=PS(5)*PMAS(23,2)
64597 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
64598 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
64599 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
64600 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
64602 ALPHA=VECT/(VECT+AXIV)
64603 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
64606 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
64607 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
64609 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
64610 & ITYPES.EQ.1)) THEN
64613 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
64614 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
64616 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
64618 ELSEIF(KFSRCE.EQ.36) THEN
64621 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
64622 & ITYPES.EQ.1)) THEN
64625 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
64626 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
64627 & ITYPES.EQ.3)) THEN
64629 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
64630 & ITYPES.EQ.2)) THEN
64632 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
64634 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
64635 & ITYPES.EQ.2)) THEN
64638 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
64639 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
64640 & ITYPES.EQ.5)) THEN
64642 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
64643 & ITYPES.EQ.2)) THEN
64645 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
64646 & ITYPES.EQ.1)) THEN
64649 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
64650 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
64652 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
64653 & ITYPES.EQ.2)) THEN
64655 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
64656 & ITYPES.EQ.1)) THEN
64659 C...g -> ~g + ~g (eikonal approximation).
64660 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
64663 M3JC=5*ICLASS+ICOMBI
64667 C...Find if interference with initial state partons.
64669 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
64670 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
64671 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
64676 KCA=PYCOMP(KFLA(I))
64677 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
64679 IF(KCII(I).NE.0) THEN
64681 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
64682 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
64683 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
64685 IIIS(I,NIIS(I))=ICSI
64690 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
64693 C...Boost interfering initial partons to rest frame
64694 C...and reconstruct their polar and azimuthal angles.
64698 K(N+I,J)=K(IPA(I),J)
64699 P(N+I,J)=P(IPA(I),J)
64703 DO 230 I=3,2+NIIS(1)
64705 K(N+I,J)=K(IIIS(1,I-2),J)
64706 P(N+I,J)=P(IIIS(1,I-2),J)
64710 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
64712 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
64713 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
64717 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
64718 & -PS(2)/PS(4),-PS(3)/PS(4))
64719 PHI=PYANGL(P(N+1,1),P(N+1,2))
64720 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
64721 THE=PYANGL(P(N+1,3),P(N+1,1))
64722 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
64723 DO 260 I=3,2+NIIS(1)
64724 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
64725 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
64727 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
64728 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
64729 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
64730 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
64734 C...Boost 3 or more partons to their rest frame.
64735 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
64736 &-PS(2)/PS(4),-PS(3)/PS(4))
64738 C...Define imagined single initiator of shower for parton system.
64740 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
64741 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
64742 IF(MSTU(21).GE.1) RETURN
64761 C...Loop over partons that may branch.
64764 IF(NPA.EQ.1) IM=NS-1
64767 IF(IM.GT.N) GOTO 600
64770 IF(KSH(IR).EQ.0) GOTO 290
64771 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
64776 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
64777 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
64778 IF(MSTU(21).GE.1) RETURN
64781 C...Position of aunt (sister to branching parton).
64782 C...Origin and flavour of daughters.
64785 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
64786 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
64798 K(N+I,2)=K(IPA(I),2)
64800 ELSEIF(KFLM.NE.21) THEN
64803 IREF(N+1-NS)=IREF(IM-NS)
64804 IREF(N+2-NS)=IABS(K(N+2,2))
64805 ELSEIF(K(IM,5).EQ.21) THEN
64813 IREF(N+1-NS)=IABS(K(N+1,2))
64814 IREF(N+2-NS)=IABS(K(N+2,2))
64817 C...Reset flags on daughters and tries made.
64822 KFLD(IP)=IABS(K(N+IP,2))
64823 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
64827 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
64831 C...Maximum virtuality of daughters.
64834 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
64835 P(N+I,5)=MIN(QMAX,PS(5))
64837 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
64838 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
64841 IF(MSTJ(43).LE.2) PEM=V(IM,2)
64842 IF(MSTJ(43).GE.3) PEM=P(IM,4)
64843 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
64844 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
64845 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
64849 IF(ISI(I).EQ.1) THEN
64851 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
64853 V(N+I,5)=P(N+I,5)**2
64856 C...Choose one of the daughters for evolution.
64858 IF(NEP.EQ.1) INUM=1
64860 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
64863 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
64865 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
64871 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
64872 RPM=P(N+I,5)/PMSD(I)
64874 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
64882 C...Cancel choice of predetermined daughter already treated.
64885 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
64886 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
64887 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
64888 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
64889 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
64892 C...Store information on choice of evolving daughter.
64896 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
64899 KFL(I)=IABS(K(IEP(I),2))
64901 ITRY(INUM)=ITRY(INUM)+1
64902 IF(ITRY(INUM).GT.200) THEN
64903 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
64904 IF(MSTU(21).GE.1) RETURN
64908 IF(KSH(IR).EQ.0) GOTO 450
64909 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
64911 C...Check if evolution already predetermined for daughter.
64913 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
64914 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
64915 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
64916 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
64917 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
64919 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
64921 IF(IPSPD.NE.0) ISSET(INUM)=1
64924 C...Select side for interference with initial state partons.
64925 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
64928 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
64930 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
64931 IF(PYR(0).GT.0.5D0) ISII(III)=1
64932 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
64934 IF(PYR(0).GT.0.5D0) ISII(III)=2
64938 C...Calculate allowed z range.
64941 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
64944 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
64945 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
64947 IF(MOD(MSTJ(43),2).EQ.1) THEN
64949 ZCE=PMTH(2,22)/PMED
64950 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
64952 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
64953 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
64955 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
64956 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
64957 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
64960 ZCE=MIN(ZCE,0.49991D0)
64961 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
64962 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
64963 P(IEP(1),5)=PMTH(1,IR)
64964 V(IEP(1),5)=P(IEP(1),5)**2
64968 C...Integral of Altarelli-Parisi z kernel for QCD.
64969 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
64970 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
64971 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
64973 C...Evolution of QQ~[3S18] state if MSTJ(191)=1.
64974 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(148).EQ.1.AND.
64975 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
64976 FBR=6D0*LOG((1D0-ZC)/ZC)
64978 ELSEIF(MSTJ(49).EQ.0) THEN
64979 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
64980 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
64982 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
64983 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
64984 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
64985 ELSEIF(MSTJ(49).EQ.1) THEN
64986 FBR=(1D0-2D0*ZC)/3D0
64987 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
64989 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
64990 ELSEIF(KFL(1).EQ.21) THEN
64991 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
64993 FBR=2D0*LOG((1D0-ZC)/ZC)
64996 C...Reset QCD probability for colourless.
64997 IF(ISCOL(IR).EQ.0) FBR=0D0
64999 C...Integral of Altarelli-Parisi kernel for photon emission.
65001 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
65002 IF(KFL(1).LE.18) THEN
65003 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
65005 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
65008 C...Inner veto algorithm starts. Find maximum mass for evolution.
65009 410 PMS=V(IEP(1),5)
65014 IRI=IREF(IEP(I)-NS)
65015 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
65018 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
65021 C...Select mass for daughter in QCD evolution.
65023 DO 430 IFF=4,MSTJ(45)
65024 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
65026 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
65027 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
65028 C...Already predetermined choice.
65029 IF(IPSPD.NE.0) THEN
65030 PMSQCD=P(IPSPD,5)**2
65031 ELSEIF(FBR.LT.1D-3) THEN
65033 ELSEIF(MSTJ(44).LE.0) THEN
65034 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
65035 ELSEIF(MSTJ(44).EQ.1) THEN
65036 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
65038 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
65040 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
65041 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
65042 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
65046 C...Select mass for daughter in QED evolution.
65047 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
65048 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
65049 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
65050 IF(FBRE.LT.1D-3) THEN
65053 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
65054 & (PARU(101)*FBRE)))
65056 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
65057 PMSQED=PMSQED+PMTH(1,IR)**2
65058 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
65060 IF(PMSQED.GT.PMSQCD) THEN
65066 C...Check whether daughter mass below cutoff.
65067 P(IEP(1),5)=SQRT(V(IEP(1),5))
65068 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
65069 P(IEP(1),5)=PMTH(1,IR)
65070 V(IEP(1),5)=P(IEP(1),5)**2
65074 C...Already predetermined choice of z, and flavour in g -> qqbar.
65075 IF(IPSPD.NE.0) THEN
65078 PMSGD1=P(IPSGD1,5)**2
65079 PMSGD2=P(IPSGD2,5)**2
65080 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
65081 & 4D0*PMSGD1*PMSGD2))
65082 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
65083 & PMSGD1+PMSGD2)/ALAMPS
65084 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
65085 IF(KFL(1).NE.21) THEN
65088 K(IEP(1),5)=IABS(K(IPSGD1,2))
65091 C...Select z value of branching: q -> qgamma.
65092 ELSEIF(MCE.EQ.2) THEN
65093 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
65094 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
65098 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
65099 ELSEIF(MSTJ(49).EQ.0.AND.
65100 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
65101 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65102 C...Select always the harder 'gluon' if the switch MSTP(149)=0.
65103 IF(MSTP(149).EQ.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
65104 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
65108 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
65109 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
65110 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65111 C...Only do z weighting when no ME correction afterwards.
65112 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
65114 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
65115 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65116 IF(PYR(0).GT.0.5D0) Z=1D0-Z
65117 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
65119 ELSEIF(MSTJ(49).NE.1) THEN
65121 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
65122 KFLB=1+INT(MSTJ(45)*PYR(0))
65123 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
65124 IF(PMQ.GE.1D0) GOTO 410
65125 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
65126 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
65127 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
65128 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
65129 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
65131 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
65135 C...Ditto for scalar gluon model.
65136 ELSEIF(KFL(1).NE.21) THEN
65137 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
65139 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
65140 Z=ZC+(1D0-2D0*ZC)*PYR(0)
65143 Z=ZC+(1D0-2D0*ZC)*PYR(0)
65144 KFLB=1+INT(MSTJ(45)*PYR(0))
65145 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
65146 IF(PMQ.GE.1D0) GOTO 410
65150 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
65151 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
65152 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
65153 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65154 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
65156 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
65157 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
65158 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
65159 IF(PT2APP.LT.PT2MIN) GOTO 410
65160 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
65164 C...Check if z consistent with chosen m.
65165 IF(KFL(1).EQ.21) THEN
65166 IRGD1=IABS(K(IEP(1),5))
65170 IRGD2=IABS(K(IEP(1),5))
65174 ELSEIF(NEP.GE.3) THEN
65176 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
65177 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
65179 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
65180 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
65182 IF(MOD(MSTJ(43),2).EQ.1) THEN
65183 PMQTH3=0.5D0*PARJ(82)
65184 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
65185 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
65186 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
65187 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
65188 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
65192 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
65195 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
65196 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65197 ELSEIF(IPSPD.NE.0) THEN
65201 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
65203 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
65205 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
65207 C...Width suppression for q -> q + g.
65208 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
65210 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
65214 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
65215 IF(MSTJ(40).EQ.1) THEN
65216 IF(CHI.LT.PYR(0)) GOTO 410
65217 ELSEIF(MSTJ(40).EQ.2) THEN
65218 IF(1D0-CHI.LT.PYR(0)) GOTO 410
65222 C...Three-jet matrix element correction.
65227 C...QED matrix elements: only for massless case so far.
65228 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
65229 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
65230 X2=1D0-V(IEP(1),5)/V(NS+1,5)
65231 X3=(1D0-X1)+(1D0-X2)
65233 KI2=K(IPA(3-INUM),2)
65234 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
65235 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
65236 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
65237 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
65238 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
65239 ELSEIF(MCE.EQ.2) THEN
65241 C...QCD matrix elements, including mass effects.
65242 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
65246 IF(IR.GE.31.AND.IGM.EQ.0) THEN
65247 C...QCD ME: original parton, first branching.
65248 PM2ME=PMTH(1,63-IR)
65250 ELSEIF(IR.GE.31) THEN
65251 C...QCD ME: original parton, subsequent branchings.
65252 PM2ME=PMTH(1,63-IR)
65253 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
65254 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65255 ELSEIF(K(IM,2).EQ.21) THEN
65256 C...QCD ME: secondary partons, first branching.
65259 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
65260 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
65261 & 4D0*PS1ME*PM2ME**2))
65262 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
65264 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65267 C...QCD ME: secondary partons, subsequent branchings.
65269 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
65270 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65273 C...Construct ME variables.
65276 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
65277 X2=1D0+R2ME**2-PS1ME/ECMME**2
65278 C...Call ME, with right order important for two inequivalent showerers.
65279 IF(IR.EQ.IORD+30) THEN
65280 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
65282 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
65284 C...Split up total ME when two radiating partons.
65286 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
65287 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
65288 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
65289 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
65290 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
65291 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
65292 & MAX(1D-10,2D0-X1-X2)
65293 C...Evaluate shower rate to be compared with.
65294 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
65295 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
65296 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
65297 ELSEIF(MSTJ(49).NE.1) THEN
65299 C...Toy model scalar theory matrix elements; no mass effects.
65301 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
65302 X2=1D0-V(IEP(1),5)/V(NS+1,5)
65303 X3=(1D0-X1)+(1D0-X2)
65304 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
65306 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
65310 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
65313 C...Impose angular ordering by rejection of nonordered emission.
65314 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
65315 PEMAO=V(IM,1)*P(IM,4)
65316 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
65317 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
65319 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
65320 & .OR.MSTJ(42).EQ.7)) THEN
65322 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
65323 & .OR.MSTJ(42).EQ.6)) THEN
65325 PMDAO=PMTH(2,K(IEP(1),5))
65326 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
65329 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
65330 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
65331 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
65335 440 IF(K(IAOM,5).EQ.22) THEN
65337 IF(K(IAOM,3).LE.NS) MAOM=0
65338 IF(MAOM.EQ.1) GOTO 440
65340 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
65341 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
65342 IF(THE2ID.LT.THE2IM) GOTO 410
65346 C...Impose user-defined maximum angle at first branching.
65347 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
65348 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
65349 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
65350 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
65351 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
65352 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
65353 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
65354 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
65355 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
65356 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
65360 C...Impose angular constraint in first branching from interference
65361 C...with initial state partons.
65362 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
65363 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
65364 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
65365 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
65366 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
65367 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
65371 C...End of inner veto algorithm. Check if only one leg evolved so far.
65375 IF(NEP.EQ.1) GOTO 490
65376 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
65379 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
65380 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
65384 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
65388 PMSUM=PMSUM+P(N+I,5)
65390 IF(PMSUM.GE.PS(5)) GOTO 350
65391 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
65394 IF(KSH(IRDA).EQ.0) GOTO 480
65395 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
65396 IF(IRDA.EQ.21) THEN
65397 IRGD1=IABS(K(I1,5))
65401 IRGD2=IABS(K(I1,5))
65404 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
65405 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
65407 IF(I1.EQ.N+1) ZM=V(IM,1)
65408 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
65409 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
65410 & 4D0*V(N+1,5)*V(N+2,5))
65411 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
65414 IF(MOD(MSTJ(43),2).EQ.1) THEN
65415 PMQTH3=0.5D0*PARJ(82)
65416 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
65417 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
65418 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
65419 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
65420 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
65424 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
65427 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
65428 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65432 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
65433 & ISSET(1).EQ.0) THEN
65435 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
65436 & ISSET(2).EQ.0) THEN
65440 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
65442 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
65444 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
65447 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
65448 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
65449 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
65450 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
65451 IF(ISL(1).EQ.1) ISL(2)=0
65452 IF(ISL(1).EQ.0) ISLM=1
65453 IF(ISL(2).EQ.0) ISLM=2
65455 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
65460 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
65461 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
65462 PMQ1=V(N+1,5)/V(IM,5)
65463 PMQ2=V(N+2,5)/V(IM,5)
65464 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
65469 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
65473 C...Accepted branch. Construct four-momentum for initial partons.
65479 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
65481 P(N+1,4)=P(IPA(1),4)
65483 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
65484 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
65487 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
65492 P(N+2,4)=P(IM,5)-PED1
65495 ELSEIF(NEP.GE.3) THEN
65496 C...Rescale all momenta for energy conservation.
65502 P(N+I,J)=P(IPA(I),J)
65505 PQS=PQS+P(N+I,5)**2/P(N+I,4)
65508 FAC=(PS(5)-PQS)/(PES-PQS)
65513 P(N+I,J)=FAC*P(N+I,J)
65515 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)
65518 PQS=PQS+P(N+I,5)**2/P(N+I,4)
65520 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
65522 C...Construct transverse momentum for ordinary branching in shower.
65526 550 LOOPPT=LOOPPT+1
65527 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
65528 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
65529 IF(PZM.LE.0D0) THEN
65531 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65532 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65533 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
65534 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
65535 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
65536 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
65538 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
65540 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
65543 ELSEIF(PTS.LT.0D0) THEN
65546 PT=SQRT(MAX(0D0,PTS))
65548 C...Global statistics.
65549 MINT(353)=MINT(353)+1
65550 VINT(353)=VINT(353)+PT
65551 IF (MINT(353).EQ.1) VINT(358)=PT
65553 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
65555 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
65556 & .AND.IAU.NE.0) THEN
65557 IF(K(IGM,3).NE.0) MAZIP=1
65559 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
65560 IF(MAZIP.EQ.0) ZAU=0D0
65561 IF(K(IGM,2).NE.21) THEN
65562 HAZIP=2D0*ZAU/(1D0+ZAU**2)
65564 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
65566 IF(K(N+1,2).NE.21) THEN
65567 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
65569 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
65573 C...Find coefficient of azimuthal asymmetry due to soft gluon
65576 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
65577 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
65578 IF(K(IGM,3).NE.0) MAZIC=N+1
65579 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
65580 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
65581 & ZM.GT.0.5D0) MAZIC=N+2
65582 IF(K(IAU,2).EQ.22) MAZIC=0
65584 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
65586 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
65587 IF(MAZIC.EQ.0) ZGM=1D0
65588 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
65589 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
65590 HAZIC=MIN(0.95D0,HAZIC)
65594 C...Construct energies for ordinary branching in shower.
65595 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
65596 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65597 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65598 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
65599 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
65600 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
65601 P(N+1,4)=PEM*V(IM,1)
65603 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
65604 & SQRT(PMLS)*ZM)/V(IM,5)
65607 C...Already predetermined choice of phi angle or not
65609 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
65611 IF(K(IPSPD,4).GT.0) THEN
65613 IF(IM.EQ.NS+2) THEN
65614 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
65616 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
65619 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
65621 IF(K(IPSPD,4).GT.0) THEN
65623 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
65624 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
65625 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
65626 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
65627 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
65628 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
65632 C...Construct momenta for ordinary branching in shower.
65633 P(N+1,1)=PT*COS(PHI)
65634 P(N+1,2)=PT*SIN(PHI)
65635 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65636 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65637 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
65638 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
65639 ELSEIF(PZM.GT.0D0) THEN
65640 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
65641 & 2D0*PEM*P(N+1,4))/PZM
65647 P(N+2,3)=PZM-P(N+1,3)
65648 P(N+2,4)=PEM-P(N+1,4)
65649 IF(MSTJ(43).LE.2) THEN
65650 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
65651 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
65655 C...Rotate and boost daughters.
65657 IF(MSTJ(43).LE.2) THEN
65658 BEX=P(IGM,1)/P(IGM,4)
65659 BEY=P(IGM,2)/P(IGM,4)
65660 BEZ=P(IGM,3)/P(IGM,4)
65661 GA=P(IGM,4)/P(IGM,5)
65662 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
65671 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
65672 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
65673 IF(PTIMB.GT.1D-4) THEN
65674 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
65679 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
65680 & SIN(THE)*COS(PHI)*P(I,3)
65681 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
65682 & SIN(THE)*SIN(PHI)*P(I,3)
65683 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
65685 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
65686 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
65687 P(I,1)=DP(1)+DGABP*BEX
65688 P(I,2)=DP(2)+DGABP*BEY
65689 P(I,3)=DP(3)+DGABP*BEZ
65690 P(I,4)=GA*(DP(4)+DBP)
65694 C...Weight with azimuthal distribution, if required.
65695 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
65701 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
65702 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
65703 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
65705 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
65706 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
65708 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
65709 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
65710 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
65711 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
65712 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
65713 IF(MAZIP.NE.0) THEN
65714 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
65717 IF(MAZIC.NE.0) THEN
65718 IF(MAZIC.EQ.N+2) CAD=-CAD
65719 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
65720 & .LT.PYR(0)) GOTO 560
65725 C...Azimuthal anisotropy due to interference with initial state partons.
65726 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
65727 &K(N+2,2).EQ.21)) THEN
65729 IF(ISII(III).GE.1) THEN
65731 IF(K(N+1,2).NE.21) IAZIID=N+2
65732 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
65733 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
65734 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
65735 IF(III.EQ.2) THEIID=PARU(1)-THEIID
65736 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
65737 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
65738 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
65739 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
65740 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
65741 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
65742 & .LT.PYR(0)) GOTO 560
65746 C...Continue loop over partons that may branch, until none left.
65747 IF(IGM.GE.0) K(IM,1)=14
65750 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
65751 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
65752 IF(MSTU(21).GE.1) N=NS
65753 IF(MSTU(21).GE.1) RETURN
65757 C...Set information on imagined shower initiator.
65758 600 IF(NPA.GE.2) THEN
65762 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
65770 C...Reconstruct string drawing information.
65771 DO 610 I=NS+1+IIM,N
65772 KQ=KCHG(PYCOMP(K(I,2)),2)
65773 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
65775 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
65776 & IABS(K(I,2)).LE.18) THEN
65778 ELSEIF(K(I,1).LE.10) THEN
65779 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
65780 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
65781 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
65782 ID1=MOD(K(I,4),MSTU(5))
65783 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
65784 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
65785 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
65786 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
65787 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
65788 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
65789 K(ID1,4)=K(ID1,4)+MSTU(5)*I
65790 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
65791 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
65792 K(ID2,5)=K(ID2,5)+MSTU(5)*I
65794 ID1=MOD(K(I,4),MSTU(5))
65796 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
65797 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
65798 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
65799 K(ID1,4)=K(ID1,4)+MSTU(5)*I
65800 K(ID1,5)=K(ID1,5)+MSTU(5)*I
65810 C...Transformation from CM frame.
65812 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
65813 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
65815 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
65816 ELSEIF(NPA.EQ.2) THEN
65821 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
65822 & /(1D0+GA)-P(IPA(1),4))
65823 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
65824 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
65825 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
65827 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
65829 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
65832 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
65835 C...Decay vertex of shower.
65842 C...Delete trivial shower, else connect initiators.
65843 IF(N.LE.NS+NPA+IIM) THEN
65848 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
65849 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
65850 K(NS+IIM+IP,3)=IPA(IP)
65851 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
65852 IF(K(NS+IIM+IP,1).NE.1) THEN
65853 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
65854 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
65862 C*********************************************************************
65865 C...Generates pT-ordered timelike final-state parton showers.
65867 C...MODE defines how to find radiators and recoilers.
65868 C... = 0 : based on colour flow between undecayed partons.
65869 C... = 1 : for IPART <= NPARTD only consider primary partons,
65870 C... whether decayed or not; else as above.
65871 C... = 2 : based on common history, whether decayed or not.
65873 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
65875 C...Double precision and integer declarations.
65876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65877 IMPLICIT INTEGER(I-N)
65878 INTEGER PYK,PYCHGE,PYCOMP
65879 C...Parameter statement to help give large particle numbers.
65880 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65881 &KEXCIT=4000000,KDIMEN=5000000)
65882 C...Parameter statement for maximum size of showers.
65883 PARAMETER (MAXNUR=1000)
65885 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65886 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65887 COMMON/PYCTAG/NCT,MCT(4000,2)
65888 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65889 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65890 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65891 COMMON/PYINT1/MINT(400),VINT(400)
65892 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
65895 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
65896 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
65897 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
65898 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
65899 C...Statement functions.
65900 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
65901 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
65903 C...Initial values. Check that valid system.
65905 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
65906 &MSTJ(41).NE.12) RETURN
65907 IF(NPART.LE.0) THEN
65908 CALL PYERRM(2,'(PYPTFS:) showering system too small')
65913 C...Mass thresholds and Lambda for QCD evolution.
65917 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
65918 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
65925 C...Cutoff scale for QCD evolution. Starting pT2.
65926 NFLAV=MAX(0,MIN(5,MSTJ(45)))
65927 PT0C=0.5D0*PARJ(82)
65928 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
65930 C...Parameters for QED evolution.
65931 AEM2PI=PARU(101)/PARU(2)
65932 PT0EQ=0.5D0*PARJ(83)
65933 PT0EL=0.5D0*PARJ(90)
65935 C...Reset. Remove irrelevent colour tags.
65940 DO 110 I=MINT(84)+1,N
65941 IF(K(I,2).GT.0.AND.K(I,2).LT.6) K(I,5)=0
65942 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) K(I,4)=0
65946 C...Begin loop to set up showering partons. Sum four-momenta.
65949 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
65950 IF(K(I,1).GT.10) GOTO 210
65951 ELSEIF(K(I,3).GT.MINT(84)) THEN
65952 IF(K(I,3).GT.MINT(84)+2) GOTO 210
65954 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
65957 PSUM(J)=PSUM(J)+P(I,J)
65960 C...Find colour and charge, but skip diquarks.
65961 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
65962 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
65963 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
65965 C...Either colour or anticolour charge radiates; for gluon both.
65966 DO 160 JSGCOL=1,-1,-2
65967 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
65968 JCOL=4+(1-JSGCOL)/2
65971 C...Basic info about radiating parton.
65975 ISCOL(NEVOL)=JSGCOL
65977 PTSCA(NEVOL)=PTPART(IP)
65979 C...Begin search for colour recoiler when MODE = 0 or 1.
65981 C...Find sister with matching anticolour to the radiating parton.
65983 IRNEW=K(IROLD,JCOL)/MSTU(5)
65986 C...Skip radiation off loose colour ends.
65987 130 IF(IRNEW.EQ.0) THEN
65991 C...Optionally skip radiation on dipole to beam remnant.
65992 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
65996 C...For now always skip radiation on dipole to junction.
65997 ELSEIF(K(IRNEW,2).EQ.88) THEN
66001 C...For MODE=1: if reached primary then done.
66002 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
66003 & IRNEW.LE.NPARTD) THEN
66005 C...If sister stable and points back then done.
66006 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
66008 IF(K(IRNEW,1).LT.10) THEN
66010 C...If sister unstable then go to her daughter.
66013 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66018 C...If found mother then look for aunt.
66019 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
66022 IRNEW=K(IROLD,JCOL)/MSTU(5)
66025 C...If daughter stable then done.
66026 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
66028 IF(K(IRNEW,1).LT.10) THEN
66030 C...If daughter unstable then go to granddaughter.
66033 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66038 C...If daughter points to another daughter then done or move up.
66039 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
66041 IF(K(IRNEW,1).LT.10) THEN
66044 IRNEW=K(IRNEW,JCOL)/MSTU(5)
66050 C...Begin search for colour recoiler when MODE = 2.
66053 IRNEW=K(IROLD,JCOL)/MSTU(5)
66054 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
66055 C...Step up to mother if radiating parton already branched.
66056 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
66058 IRNEW=K(IROLD,JCOL)/MSTU(5)
66060 C...Pick sister by history if no anticolour available.
66062 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
66064 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
66067 C...Last resort: pick at random among other primaries.
66069 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
66070 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
66074 C...Trace down if sister branched.
66075 150 IF(K(IRNEW,1).GT.10) THEN
66076 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66081 C...Now found other end of colour dipole.
66086 C...Also electrical charge may radiate; so far only quarks and leptons.
66087 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
66088 & IABS(K(I,2)).LE.18) THEN
66090 C...Basic info about radiating parton.
66096 PTSCA(NEVOL)=PTPART(IP)
66098 C...Pick nearest (= smallest invariant mass) charged particle
66099 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
66103 DO 170 IP2=1,NPART+N-MINT(53)
66104 IF(IP2.EQ.IP) GOTO 170
66105 IF(IP2.LE.NPART) THEN
66107 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
66108 IF(K(I2,1).GT.10) GOTO 170
66109 ELSEIF(K(I2,3).GT.MINT(84)) THEN
66110 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
66112 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
66115 I2=MINT(53)+IP2-NPART
66117 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
66118 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
66119 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
66120 IF(PM2INV.LT.PM2MIN) THEN
66125 IF(IRNEW.EQ.0) THEN
66130 C...Begin search for charge recoiler when MODE = 2.
66133 C...Pick sister by history; step up if parton already branched.
66134 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
66138 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
66140 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
66142 C...Last resort: pick at random among other primaries.
66144 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
66145 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
66147 C...Trace down if sister branched.
66148 190 IF(K(IRNEW,1).GT.10) THEN
66149 DO 200 IR=IRNEW+1,N
66150 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
66160 C...End loop to set up showering partons. System invariant mass.
66162 IF(NEVOL.LE.0) RETURN
66163 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
66165 C...Check if 3-jet matrix elements to be used.
66169 IF(MSTJ(47).GE.1) THEN
66171 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
66173 IPART1=K(IPART(1),3)
66174 IPART2=K(IPART(2),3)
66175 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
66176 KFSRCE=IABS(K(IPART1,2))
66177 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
66180 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
66185 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
66186 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
66187 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
66188 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
66189 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
66190 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
66191 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
66192 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
66194 C...Identify two primary showerers.
66195 KFLA1=IABS(K(IPART(1),2))
66197 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
66198 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
66199 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
66200 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
66201 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
66202 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
66203 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
66204 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
66205 KFLA2=IABS(K(IPART(2),2))
66207 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
66208 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
66209 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
66210 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
66211 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
66212 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
66213 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
66214 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
66216 C...Order of showerers. Presence of gluino.
66217 ITYPMN=MIN(ITYPE1,ITYPE2)
66218 ITYPMX=MAX(ITYPE1,ITYPE2)
66220 IF(ITYPE1.GT.ITYPE2) IORD=2
66222 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
66224 C...Require exactly two primary showerers for ME corrections.
66227 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
66229 IF(NPRIM.NE.2) THEN
66231 C...Predetermined and default matrix element kinds.
66232 ELSEIF(MSTJ(38).NE.0) THEN
66236 ELSEIF(MSTJ(47).GE.6) THEN
66242 C...Vector/axial vector -> q + qbar; q -> q + V.
66243 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
66244 & ITYPES.EQ.3)) THEN
66246 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
66248 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
66249 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
66250 C...gamma*/Z0: assume e+e- initial state if unknown.
66252 IF(KFSRCE.EQ.23) THEN
66254 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
66255 IF(IANNFL.NE.0) THEN
66256 KANNFL=IABS(K(IANNFL,2))
66257 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
66260 AI=SIGN(1D0,EI+0.1D0)
66261 VI=AI-4D0*EI*PARU(102)
66262 EF=KCHG(KFLA1,1)/3D0
66263 AF=SIGN(1D0,EF+0.1D0)
66264 VF=AF-4D0*EF*PARU(102)
66265 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66268 SQWZ=PSUM(5)*PMAS(23,2)
66269 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66270 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66271 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66272 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66274 ALPHA=VECT/(VECT+AXIV)
66275 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66278 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66279 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66281 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66282 & ITYPES.EQ.1)) THEN
66285 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66286 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66288 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66290 ELSEIF(KFSRCE.EQ.36) THEN
66293 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66294 & ITYPES.EQ.1)) THEN
66297 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66298 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66299 & ITYPES.EQ.3)) THEN
66301 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66302 & ITYPES.EQ.2)) THEN
66304 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66306 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66307 & ITYPES.EQ.2)) THEN
66310 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66311 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66312 & ITYPES.EQ.5)) THEN
66314 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66315 & ITYPES.EQ.2)) THEN
66317 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66318 & ITYPES.EQ.1)) THEN
66321 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66322 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66324 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66325 & ITYPES.EQ.2)) THEN
66327 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66328 & ITYPES.EQ.1)) THEN
66331 C...g -> ~g + ~g (eikonal approximation).
66332 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66335 M3JC=5*ICLASS+ICOMBI
66338 C...Store pair that together define matrix element treatment.
66341 MESYS(NMESYS,0)=M3JC
66342 MESYS(NMESYS,1)=IPART(1)
66343 MESYS(NMESYS,2)=IPART(2)
66346 C...Store qqbar or l+l- pairs for QED radiation.
66347 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
66349 MESYS(NMESYS,0)=101
66350 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
66351 MESYS(NMESYS,1)=IPART(1)
66352 MESYS(NMESYS,2)=IPART(2)
66355 C...Store other qqbar/l+l- pairs from g/gamma branchings.
66357 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
66359 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
66363 C...Move up this check to avoid out-of-bounds.
66364 IF(I1M.EQ.0) GOTO 270
66365 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
66367 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
66369 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
66373 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
66379 MESYS(NMESYS,0)=102
66387 C..Loopback point for counting number of emissions.
66391 C...Begin loop to evolve all existing partons, if required.
66394 DO 360 IEVOL=1,NEVOL
66395 IF(IFLG(IEVOL).EQ.0) THEN
66397 C...Basic info on radiator and recoil.
66404 C...Invariant mass of "dipole".Starting value for pT evolution.
66405 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
66406 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
66408 C...Case of evolution by QCD branching.
66409 IF(ISCOL(IEVOL).NE.0) THEN
66411 C...Parton-by-parton maximum scale from initial conditions.
66412 IF(MSTP(72).EQ.0) THEN
66413 DO 300 IPRT=1,NPARTS
66414 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
66418 C...If kinematically impossible then do not evolve.
66419 IF(PT2.LT.PT2CMN) THEN
66424 C...Check if part of system for which ME corrections should be applied.
66426 DO 310 IME=1,NMESYS
66427 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
66428 & MESYS(IME,0).LT.100) IMESYS=IME
66431 C...Special flag for colour octet states.
66433 IF(K(I,2).EQ.21) MOCT=1
66434 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
66436 C...Upper estimate for matrix element weighting and colour factor.
66437 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
66440 IF(MOCT.GE.1) COLFAC=3D0/2D0
66441 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
66442 WTPSQQ=0.5D0*0.5D0*NFLAV
66444 C...Determine overestimated z range: switch at c and b masses.
66449 IF(PT2.GT.1.01D0*PMCS) THEN
66455 IF(PT2.GT.1.01D0*PMBS) THEN
66461 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
66462 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
66464 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
66465 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
66468 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
66469 EVCOEF=EVCOEF+EVEMQQ
66472 C...Pick pT2 (in overestimated z range).
66473 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
66475 C...Loopback if crossed c/b mass thresholds.
66476 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
66480 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
66485 C...Finish if below lower cutoff.
66486 IF(PT2.LT.PT2CMN) THEN
66491 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
66493 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
66495 C...Pick z: dz/(1-z) or dz.
66496 IF(IFLAG.EQ.1) THEN
66497 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
66499 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
66502 C...Loopback if outside allowed range for given pT2.
66503 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
66504 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
66505 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
66506 PM2=PM2I+PT2/(Z*(1D0-Z))
66507 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
66509 C...No weighting for primary partons; to be done later on.
66510 IF(IMESYS.GT.0) THEN
66512 C...Weighting of q->qg/X->Xg branching.
66513 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
66514 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
66516 C...Weighting of g->gg branching.
66517 ELSEIF(IFLAG.EQ.1) THEN
66518 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
66520 C...Flavour choice and weighting of g->qqbar branching.
66522 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
66524 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
66525 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
66526 IF(WTME.LT.PYR(0)) GOTO 330
66530 C...Case of evolution by QED branching.
66531 ELSEIF(ISCHG(IEVOL).NE.0) THEN
66533 C...If kinematically impossible then do not evolve.
66535 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
66536 IF(PT2.LT.PT2EMN) THEN
66541 C...Check if part of system for which ME corrections should be applied.
66543 DO 340 IME=1,NMESYS
66544 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
66545 & MESYS(IME,0).GT.100) IMESYS=IME
66548 C...Charge. Matrix element weighting factor.
66549 CHG=ISCHG(IEVOL)/3D0
66552 C...Determine overestimated z range. Find evolution coefficient.
66553 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
66554 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
66555 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
66557 C...Pick pT2 (in overestimated z range).
66558 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
66560 C...Finish if below lower cutoff.
66561 IF(PT2.LT.PT2EMN) THEN
66566 C...Pick z: dz/(1-z).
66567 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
66569 C...Loopback if outside allowed range for given pT2.
66570 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
66571 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
66572 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
66573 PM2=PM2I+PT2/(Z*(1D0-Z))
66574 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
66576 C...Weighting by branching kernel, except if ME weighting later.
66577 IF(IMESYS.EQ.0) THEN
66578 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
66583 C...Save acceptable branching.
66585 IMESAV(IEVOL)=IMESYS
66591 C...Check if branching has highest pT.
66592 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
66594 PT2MX=PT2SAV(IEVOL)
66598 C...Finished if no more branchings to be done.
66599 IF(IMX.EQ.0) GOTO 480
66601 C...Restore info on hardest branching to be processed.
66612 PM2=PM2I+PT2/(Z*(1D0-Z))
66614 C...Special flag for colour octet states.
66616 IF(K(I,2).EQ.21) MOCT=1
66617 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
66619 C...Restore further info for g->qqbar branching.
66621 IF(IFLG(IMX).GT.10) THEN
66624 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
66627 C...For branching g include azimuthal asymmetries from polarization.
66629 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
66630 C...Trace grandmother via intermediate recoil copies.
66633 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
66634 & K(IM,3).GT.0) THEN
66636 IF(IM.GT.MINT(84)) GOTO 370
66639 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
66640 & KFGM=IABS(K(IGM,2))
66641 C...Define approximate energy sharing by identifying aunt.
66643 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
66644 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
66645 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
66646 C...Coefficient from gluon production.
66648 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
66650 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
66652 C...Coefficient from gluon decay.
66654 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
66656 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
66661 C...Create new slots for branching products and recoil.
66667 C...Set status, flavour and mother of new ones.
66670 IF(KCHA.NE.0) K(IGNEW,1)=1
66675 IF(KCHA.NE.0) K(IGNEW,2)=22
66677 K(INEW,2)=-ISIGN(KFQ,KCOL)
66678 K(IGNEW,2)=-K(INEW,2)
66685 C...Find rest frame and angles of branching+recoil.
66691 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
66692 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
66693 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
66694 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
66695 PHI=PYANGL(P(INEW,1),P(INEW,2))
66696 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
66698 C...Derive kinematics of branching: generics (like g->gg).
66703 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
66704 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
66705 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
66706 PTCOR=SQRT(MAX(0D0,PT2COR))
66707 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
66708 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
66709 C...Specific kinematics reduction for q->qg with m_q > 0.
66711 PTCOR=(1D0-PM2I/PM2)*PTCOR
66712 PZN=PZN+PM2I*PZG/PM2
66713 PZG=(1D0-PM2I/PM2)*PZG
66714 C...Specific kinematics reduction for g->qqbar with m_q > 0.
66715 ELSEIF(KFQ.NE.0) THEN
66719 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
66723 C...Pick phi and construct kinematics of branching.
66724 400 PHIROT=PARU(2)*PYR(0)
66725 P(INEW,1)=PTCOR*COS(PHIROT)
66726 P(INEW,2)=PTCOR*SIN(PHIROT)
66728 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
66729 P(IGNEW,1)=-P(INEW,1)
66730 P(IGNEW,2)=-P(INEW,2)
66732 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
66736 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
66738 C...Boost branching system to lab frame.
66739 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
66741 C...Renew choice of phi angle according to polarization asymmetry.
66742 IF(ABS(ASYPOL).GT.1D-3) THEN
66748 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
66749 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
66750 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
66752 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
66753 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
66755 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
66756 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
66757 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
66758 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
66759 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
66760 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
66765 C...Matrix element corrections for primary partons when requested.
66766 IF(IMESYS.GT.0) THEN
66767 M3JC=MESYS(IMESYS,0)
66769 C...Identify recoiling partner and set up three-body kinematics.
66770 IRP=MESYS(IMESYS,1)
66771 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
66772 IF(IRP.EQ.IR) IRP=IRNEW
66774 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
66776 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
66778 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
66779 & PSUM(3)*P(INEW,3))/PSUM(5)**2
66780 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
66781 & PSUM(3)*P(IRP,3))/PSUM(5)**2
66783 R1ME=P(INEW,5)/PSUM(5)
66784 R2ME=P(IRP,5)/PSUM(5)
66786 C...Matrix elements for gluon emission.
66787 IF(M3JC.LT.100) THEN
66789 C...Call ME, with right order important for two inequivalent showerers.
66790 IF(MESYS(IMESYS,IORD).EQ.I) THEN
66791 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
66793 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
66796 C...Split up total ME when two radiating partons.
66798 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
66799 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
66800 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
66801 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66802 & MAX(1D-10,2D0-X1-X2)
66804 C...Evaluate shower rate.
66805 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
66806 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66807 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
66809 C...Matrix elements for photon emission: still rather primitive.
66812 C...For generic charge combination currently only massless expression.
66813 IF(M3JC.EQ.101) THEN
66814 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
66815 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
66816 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66817 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
66819 C...For flavour neutral system assume vector source and include masses.
66821 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
66822 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
66823 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
66824 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66828 C...Perform weighting with W_ME/W_PS.
66829 IF(WME.LT.PYR(0)*WPS) THEN
66836 C...Now for sure accepted branching. Save highest pT.
66837 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
66839 C...Update status for obsolete ones. Bookkkep the moved original parton
66840 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
66841 C...Do not bookkeep radiated photon, since it cannot radiate further.
66845 IF(IPART(IP).EQ.I) IPART(IP)=INEW
66846 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
66853 C...Initialize colour flow of branching.
66854 C...Use both old and new style colour tags for flexibility.
66868 C...Trivial colour flow for l->lgamma and q->qgamma.
66869 IF(IABS(KCHA).EQ.3) THEN
66872 ELSEIF(KCHA.NE.0) THEN
66873 IF(K(I,4).NE.0) THEN
66875 K(INEW,4)=MSTU(5)*I
66876 MCT(INEW,1)=MCT(I,1)
66878 IF(K(I,5).NE.0) THEN
66880 K(INEW,5)=MSTU(5)*I
66881 MCT(INEW,2)=MCT(I,2)
66884 C...Set colour flow for q->qg and g->gg.
66885 ELSEIF(KFQ.EQ.0) THEN
66886 K(I,JCOLP)=K(I,JCOLP)+IGNEW
66887 K(IGNEW,JCOLP)=MSTU(5)*I
66888 K(INEW,JCOLP)=MSTU(5)*IGNEW
66889 K(IGNEW,JCOLN)=MSTU(5)*INEW
66890 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
66892 MCT(INEW,JCOLP-3)=NCT
66893 MCT(IGNEW,JCOLN-3)=NCT
66895 K(I,JCOLN)=K(I,JCOLN)+INEW
66896 K(INEW,JCOLN)=MSTU(5)*I
66897 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
66900 C...Set colour flow for g->qqbar.
66902 K(I,JCOLN)=K(I,JCOLN)+INEW
66903 K(INEW,JCOLN)=MSTU(5)*I
66904 K(I,JCOLP)=K(I,JCOLP)+IGNEW
66905 K(IGNEW,JCOLP)=MSTU(5)*I
66906 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
66907 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
66910 C...Daughter info for colourless recoiling parton.
66911 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
66917 C...Colour of recoiling parton sails through unchanged.
66919 IF(K(IR,4).NE.0) THEN
66920 K(IR,4)=K(IR,4)+IRNEW
66921 K(IRNEW,4)=MSTU(5)*IR
66922 MCT(IRNEW,1)=MCT(IR,1)
66924 IF(K(IR,5).NE.0) THEN
66925 K(IR,5)=K(IR,5)+IRNEW
66926 K(IRNEW,5)=MSTU(5)*IR
66927 MCT(IRNEW,2)=MCT(IR,2)
66931 C...Vertex information trivial.
66938 C...Update list of old radiators.
66939 DO 460 IEVOL=1,NEVOL
66940 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
66942 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
66945 ELSEIF(IPOS(IEVOL).EQ.I) THEN
66948 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
66951 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
66953 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
66957 C...Update links of old connected partons.
66958 IF(IREC(IEVOL).EQ.I) THEN
66961 ELSEIF(IREC(IEVOL).EQ.IR) THEN
66967 C...q->qg or g->gg: create new gluon radiators.
66968 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
66975 PTSCA(NEVOL)=SQRT(PT2)
66982 PTSCA(NEVOL)=PTSCA(NEVOL-1)
66985 C...Update matrix elements parton list and add new for g/gamma->qqbar.
66986 DO 470 IME=1,NMESYS
66987 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
66988 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
66989 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
66990 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
66995 MESYS(NMESYS,1)=INEW
66996 MESYS(NMESYS,2)=IGNEW
66998 MESYS(NMESYS,0)=102
66999 MESYS(NMESYS,1)=INEW
67000 MESYS(NMESYS,2)=IGNEW
67003 C...Global statistics.
67004 MINT(353)=MINT(353)+1
67005 VINT(353)=VINT(353)+PTCOR
67006 IF (MINT(353).EQ.1) VINT(358)=PTCOR
67008 C...Loopback for more emissions if enough space.
67010 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
67011 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
67014 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
67023 C*********************************************************************
67026 C...Auxiliary to PYSHOW and PYPTFS.
67027 C...Matrix elements for gluon (or photon) emission from
67028 C...a two-body state; to be used by the parton shower routine.
67029 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
67030 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
67031 C... = (alpha-strong/2 pi) * CF * PYMAEL,
67032 C...i.e. normalization is such that one recovers the familiar
67033 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
67034 C...Coupling structure:
67035 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
67036 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
67037 C... = 16-19 : q -> q V
67038 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
67039 C... = 26-29 : q -> q S
67040 C... = 31-34 : V -> ~q ~qbar (~q = squark)
67041 C... = 36-39 : ~q -> ~q V
67042 C... = 41-44 : S -> ~q ~qbar
67043 C... = 46-49 : ~q -> ~q S
67044 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
67045 C... = 56-59 : ~q -> q chi
67046 C... = 61-64 : q -> ~q chi
67047 C... = 66-69 : ~g -> q ~qbar
67048 C... = 71-74 : ~q -> q ~g
67049 C... = 76-79 : q -> ~q ~g
67050 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
67051 C...Note that the order of the decay products is important.
67052 C...In each set of four, the variants are ordered as:
67053 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
67054 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
67055 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
67056 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
67058 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
67060 C...Double precision and integer declarations.
67061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67062 IMPLICIT INTEGER(I-N)
67064 C...Check input values. Return zero outside allowed phase space.
67066 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
67067 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
67068 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
67069 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
67070 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
67071 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
67073 C...Initial values and flags.
67081 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
67083 C...Eikonal expression; also acts as default.
67084 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
67086 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
67088 ELSEIF(ICOMBI.EQ.2) THEN
67089 ANUM=(2D0-X1-X2)**2
67090 ELSEIF(ICOMBI.EQ.3) THEN
67091 ANUM=ALPCOR*(2D0-X1-X2)**2
67093 ANUM=0.5D0*(2D0-X1-X2)**2
67095 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
67096 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
67097 & R1**2/(1D0+R2**2-R1**2-X2)**2-
67098 & R2**2/(1D0+R1**2-R2**2-X1)**2)
67101 C...V -> q qbar (V = gamma*/Z0/W+-/...).
67102 ELSEIF(ICLASS.EQ.2) THEN
67103 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67104 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
67105 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
67106 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
67107 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
67108 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
67109 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
67110 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
67111 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
67112 & (-1+R1**2-R2**2+X2)**2
67113 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
67114 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
67115 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
67116 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
67117 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
67118 & -X1-X2)**2+X1*(2-X1-X2)**2)/
67119 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67120 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
67121 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
67122 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
67123 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
67124 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
67128 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67129 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
67130 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
67131 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
67132 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
67133 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
67134 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
67135 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
67136 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
67137 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
67138 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
67139 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
67140 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
67141 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
67142 & -X1-X2)**2+X1*(2-X1-X2)**2)/
67143 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67144 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
67145 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
67146 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
67147 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
67148 & +X2)/(-1-R1**2+R2**2+X1)**2
67152 IF(ICOMBI.EQ.4) THEN
67153 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
67154 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
67155 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
67156 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
67157 & (-1-R1**2+R2**2+X1)**2
67159 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
67160 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
67161 & -R1**2*X2**2+X1*X2**2)/
67162 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67163 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
67164 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
67165 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
67166 & (-1+R1**2-R2**2+X2)**2
67172 ELSEIF(ICLASS.EQ.3) THEN
67173 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67174 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
67175 & +R1**2*R2**2-2D0*R2**4)
67176 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
67177 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
67178 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
67179 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
67180 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
67181 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
67182 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
67183 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
67184 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
67185 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
67186 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67187 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67188 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
67189 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
67190 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
67191 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
67192 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67193 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
67194 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
67197 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67198 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
67199 & +R1**2*R2**2-2D0*R2**4)
67200 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
67201 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
67202 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
67203 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
67204 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
67205 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
67206 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67207 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
67208 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
67209 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
67210 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67211 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67212 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
67213 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
67214 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
67215 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
67216 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67217 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
67218 & +X1*X2**2)/(-2+X1+X2)**2
67221 IF(ICOMBI.EQ.4) THEN
67222 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
67223 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
67224 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
67225 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
67226 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
67227 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67228 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
67229 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
67230 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67231 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67232 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
67233 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
67234 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
67235 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67236 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
67237 & +X1*X2**2)/(2-X1-X2)**2
67241 C...S -> q qbar (S = h0/H0/A0/H+-/...).
67242 ELSEIF(ICLASS.EQ.4) THEN
67243 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67244 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
67245 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67246 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67247 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67248 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
67249 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
67250 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67251 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67252 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67253 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67256 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67257 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
67258 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67259 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67260 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67261 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67262 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
67263 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67264 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
67265 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
67266 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
67267 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67270 IF(ICOMBI.EQ.4) THEN
67271 RLO4=PS*(1D0-R1**2-R2**2)
67272 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
67273 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67274 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
67275 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
67276 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67277 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
67278 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67283 ELSEIF(ICLASS.EQ.5) THEN
67284 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67285 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67286 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
67287 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67288 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
67289 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67290 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
67291 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
67292 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67293 & (-1+R1**2-R2**2+X2)**2
67296 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67297 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
67298 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
67299 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67300 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
67301 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67302 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
67303 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
67304 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67305 & (-1+R1**2-R2**2+X2)**2
67308 IF(ICOMBI.EQ.4) THEN
67309 RLO4=PS*(1D0+R1**2-R2**2)
67310 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
67311 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67312 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
67313 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
67314 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
67315 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
67319 C...V -> ~q ~qbar (~q = squark).
67320 ELSEIF(ICLASS.EQ.6) THEN
67321 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
67322 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
67323 & (-1-R1**2+R2**2+X1)**2
67324 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
67325 & (-1-R1**2+R2**2+X1)
67326 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
67327 & /(-1+R1**2-R2**2+X2)**2
67328 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
67329 & (-1+R1**2-R2**2+X2)
67330 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
67331 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
67332 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
67333 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67337 ELSEIF(ICLASS.EQ.7) THEN
67338 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
67339 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
67340 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
67341 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
67342 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
67343 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
67344 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
67345 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
67346 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
67347 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
67348 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
67354 ELSEIF(ICLASS.EQ.8) THEN
67356 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
67357 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
67358 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
67359 & -R1**2*X2**2+X1*X2**2)/
67360 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
67365 ELSEIF(ICLASS.EQ.9) THEN
67367 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67368 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67369 & -(X1+X2)/(-2+X1+X2)**2
67372 C...chi -> q ~qbar (chi = neutralino/chargino).
67373 ELSEIF(ICLASS.EQ.10) THEN
67374 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67375 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67376 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
67377 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
67378 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
67379 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67380 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
67381 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67382 & (-1+R1**2-R2**2+X2)**2
67385 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67386 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
67387 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
67388 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
67389 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
67390 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67391 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
67392 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67393 & (-1+R1**2-R2**2+X2)**2
67396 IF(ICOMBI.EQ.4) THEN
67397 RLO4=PS*(1+R1**2-R2**2)
67398 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
67399 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
67400 & +X2+R1**2*X2-X1*X2/2)/
67401 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67402 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
67403 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
67408 ELSEIF(ICLASS.EQ.11) THEN
67409 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67410 RLO1=PS*(1D0-(R1+R2)**2)
67411 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
67412 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67413 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67414 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67415 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
67416 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67417 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67420 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67421 RLO2=PS*(1D0-(R1-R2)**2)
67422 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
67424 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67425 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
67426 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67427 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
67428 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67429 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67432 IF(ICOMBI.EQ.4) THEN
67433 RLO4=PS*(1D0-R1**2-R2**2)
67434 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
67435 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
67436 & +3*R1**2*X2-R2**2*X2-X1*X2)/
67437 & (-1+R1**2-R2**2+X2)**2
67438 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
67439 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
67440 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67445 ELSEIF(ICLASS.EQ.12) THEN
67446 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67447 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
67448 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67449 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
67450 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
67451 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
67452 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67453 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67456 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67457 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
67458 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
67459 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
67460 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
67461 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
67462 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67463 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67466 IF(ICOMBI.EQ.4) THEN
67467 RLO4=PS*(1D0-R1**2+R2**2)
67468 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67469 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
67470 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
67471 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
67472 & +R1**2*X2-X1*X2/2-X2**2/2)/
67473 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67478 ELSEIF(ICLASS.EQ.13) THEN
67479 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67480 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67481 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
67482 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
67483 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
67484 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
67485 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
67486 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
67487 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
67488 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
67489 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
67490 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
67491 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
67492 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67493 & (3*(-1+R1**2-R2**2+X2)**2)
67497 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67498 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
67499 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
67500 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
67501 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67502 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
67503 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
67504 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
67505 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
67506 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
67507 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
67508 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67509 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
67510 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
67511 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67512 & (3*(-1+R1**2-R2**2+X2)**2)
67516 IF(ICOMBI.EQ.4) THEN
67517 RLO4=PS*(1D0+R1**2-R2**2)
67518 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
67519 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
67520 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
67521 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
67522 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
67523 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67524 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
67525 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67526 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
67527 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67528 & (3*(-1+R1**2-R2**2+X2)**2)
67534 ELSEIF(ICLASS.EQ.14) THEN
67535 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67536 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
67537 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
67538 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67539 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67540 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
67541 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
67542 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
67543 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
67544 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67545 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67546 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
67547 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
67548 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
67549 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
67551 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
67552 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67553 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67557 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67558 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
67559 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
67560 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67561 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67562 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
67563 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
67564 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
67565 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
67566 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
67567 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
67568 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
67570 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
67571 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
67572 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
67573 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
67574 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
67575 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67579 IF(ICOMBI.EQ.4) THEN
67580 RLO4=PS*(1-R1**2-R2**2)
67581 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
67582 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
67583 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67584 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
67585 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
67586 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
67587 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
67588 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
67589 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
67590 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
67591 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
67592 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
67593 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
67594 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
67595 RFO4=9D0*RFO4/128D0
67600 ELSEIF(ICLASS.EQ.15) THEN
67601 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67602 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
67603 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
67604 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
67605 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
67606 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
67607 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
67608 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
67609 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
67610 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
67611 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
67612 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
67613 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
67614 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
67615 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
67616 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67620 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67621 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
67622 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
67623 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
67624 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
67625 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
67626 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
67627 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
67628 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
67629 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
67630 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67631 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
67632 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
67633 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
67634 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67635 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67639 IF(ICOMBI.EQ.4) THEN
67640 RLO4=PS*(1D0-R1**2+R2**2)
67641 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
67642 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
67643 & -R2**2*X2/2-X1*X2/2)/
67644 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
67645 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
67646 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67647 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
67648 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
67649 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
67650 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
67651 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
67652 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67657 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
67658 ELSEIF(ICLASS.EQ.16) THEN
67660 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
67662 ELSEIF(ICOMBI.EQ.2) THEN
67663 ANUM=(2D0-X1-X2)**2
67664 ELSEIF(ICOMBI.EQ.3) THEN
67665 ANUM=ALPCOR*(2D0-X1-X2)**2
67667 ANUM=0.5D0*(2D0-X1-X2)**2
67669 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
67670 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
67671 & R1**2/(1D0+R2**2-R1**2-X2)**2-
67672 & R2**2/(1D0+R1**2-R2**2-X1)**2)
67677 C...Find relevant LO and FO expression.
67678 IF(ICOMBI.EQ.0) THEN
67679 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
67682 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
67685 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
67686 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
67687 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
67688 ELSEIF(ISSET4.EQ.1) THEN
67691 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
67692 RLO=0.5D0*(RLO1+RLO2)
67693 RFO=0.5D0*(RFO1+RFO2)
67694 ELSEIF(ISSET1.EQ.1) THEN
67698 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
67709 C*********************************************************************
67712 C...Modifies an event so as to approximately take into account
67713 C...Bose-Einstein effects according to a simple phenomenological
67714 C...parametrization.
67716 SUBROUTINE PYBOEI(NSAV)
67718 C...Double precision and integer declarations.
67719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67720 IMPLICIT INTEGER(I-N)
67721 INTEGER PYK,PYCHGE,PYCOMP
67722 C...Parameter statement to help give large particle numbers.
67723 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67724 &KEXCIT=4000000,KDIMEN=5000000)
67726 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67729 COMMON/PYINT1/MINT(400),VINT(400)
67730 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
67731 C...Local arrays and data.
67732 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
67733 &BEIW(100),BEI3W(100)
67734 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
67735 C...Statement function: squared invariant mass.
67736 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
67737 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
67739 C...Boost event to overall CM frame. Calculate CM energy.
67740 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
67746 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
67747 & .AND.K(I,3).GT.0) THEN
67748 KFMA=IABS(K(K(I,3),2))
67749 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
67751 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
67753 DPS(J)=DPS(J)+P(I,J)
67756 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
67760 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
67763 C...Check if we have separated strings
67765 C...Reserve copy of particles by species at end of record.
67771 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
67772 NBE(IBE)=NBE(IBE-1)
67774 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
67775 DO 140 IIBE=1,IBE-1
67776 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
67779 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
67781 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
67782 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
67783 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
67786 NBE(IBE)=NBE(IBE)+1
67793 P(NBE(IBE),1)=0.0D0
67794 P(NBE(IBE),2)=0.0D0
67795 P(NBE(IBE),3)=0.0D0
67796 P(NBE(IBE),4)=0.0D0
67797 P(NBE(IBE),5)=0.0D0
67798 SMMIN=MIN(SMMIN,P(I,5))
67799 C...Check if particles comes from different W's or Z's
67800 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
67802 150 IF(K(IM,3).GT.0) THEN
67804 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
67806 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
67807 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
67808 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
67809 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
67812 C...Check if particles comes from different strings.
67813 IF(PARJ(94).GT.0.0D0) THEN
67815 160 IF(K(IM,3).GT.0) THEN
67817 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
67825 P(NBE(IBE),5)=-1.0D0
67828 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
67830 C...Calculate separation between W+ and W- or between two Z0's.
67831 C...No separation if there has been re-connections.
67833 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
67834 IF(K(IWP,2).EQ.23) THEN
67843 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
67844 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
67845 TAUP=-TAUPD*LOG(PYR(IDUM))
67846 TAUN=-TAUND*LOG(PYR(IDUM))
67847 DXP=TAUP*PYP(IWP,8)/DMP
67848 DXN=TAUN*PYP(IWN,8)/DMN
67850 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
67851 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
67854 C...Add separation between strings.
67855 IF(PARJ(94).GT.0.0D0) THEN
67856 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
67861 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
67862 DO 220 IBE=1,MIN(9,MSTJ(52))
67863 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
67866 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
67867 IF(I2M.EQ.I1M) GOTO 200
67869 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
67870 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
67871 & (P(I1,5)+P(I2,5))**2
67872 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
67881 C...Tabulate integral for subsequent momentum shift.
67882 DO 400 IBE=1,MIN(9,MSTJ(52))
67883 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
67884 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
67886 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
67887 & NBE(7)-NBE(6)).LE.1) GOTO 270
67888 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
67889 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
67890 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
67891 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
67892 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
67893 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
67894 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
67895 QDELW=0.1D0*MIN(PMHQ,SIGW)
67896 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
67897 IF(MSTJ(51).EQ.1) THEN
67898 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
67899 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
67900 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
67901 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
67902 BEEX=EXP(0.5D0*QDEL/PARJ(93))
67903 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
67904 BEEXW=EXP(0.5D0*QDELW/SIGW)
67905 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
67906 BERT=EXP(-QDEL/PARJ(93))
67907 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
67908 BERTW=EXP(-QDELW/SIGW)
67909 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
67911 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
67912 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
67913 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
67914 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
67917 QBIN=QDEL*(IBIN-0.5D0)
67918 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67919 IF(MSTJ(51).EQ.1) THEN
67921 BEI(IBIN)=BEI(IBIN)*BEEX
67923 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
67925 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
67927 DO 240 IBIN=1,NBIN3
67928 QBIN=QDEL3*(IBIN-0.5D0)
67929 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67930 IF(MSTJ(51).EQ.1) THEN
67932 BEI3(IBIN)=BEI3(IBIN)*BEEX3
67934 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
67936 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
67938 DO 250 IBIN=1,NBINW
67939 QBIN=QDELW*(IBIN-0.5D0)
67940 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67941 IF(MSTJ(51).EQ.1) THEN
67943 BEIW(IBIN)=BEIW(IBIN)*BEEXW
67945 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
67947 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
67949 DO 260 IBIN=1,NBIN3W
67950 QBIN=QDEL3W*(IBIN-0.5D0)
67951 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
67952 & SQRT(QBIN**2+PMHQ**2)
67953 IF(MSTJ(51).EQ.1) THEN
67954 BEEX3W=BEEX3W*BERT3W
67955 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
67957 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
67959 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
67962 C...Loop through particle pairs and find old relative momentum.
67963 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
67965 DO 380 I2M=I1M+1,NBE(IBE)
67966 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
67967 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
67969 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
67970 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
67971 IF(Q2OLD.LE.0.0D0) GOTO 380
67974 C...Calculate new relative momentum.
67979 IF(QOLD.LT.1D-3*QDEL) THEN
67981 ELSEIF(QOLD.LE.QDEL) THEN
67983 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
67986 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
67987 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
67988 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
67990 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
67992 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
67993 IF(QOLD.LT.1D-3*QDEL3) THEN
67995 ELSEIF(QOLD.LE.QDEL3) THEN
67997 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
68000 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
68001 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
68002 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
68004 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68006 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
68009 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
68010 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
68011 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
68013 IF(QOLD.LT.1D-3*QDELW) THEN
68015 ELSEIF(QOLD.LE.QDELW) THEN
68017 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
68020 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
68021 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
68022 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
68024 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68026 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
68027 IF(QOLD.LT.1D-3*QDEL3W) THEN
68029 ELSEIF(QOLD.LE.QDEL3W) THEN
68031 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
68034 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
68035 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
68036 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68038 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68040 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
68042 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
68044 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
68046 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
68047 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
68049 IF(MSTJ(54).GE.1) THEN
68050 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
68052 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
68053 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
68055 ELSEIF(MSTJ(54).LE.-1) THEN
68056 EDEL=P(I1,4)+P(I2,4)-
68057 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
68058 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
68059 & (P(I1,3)-P(I2,3))**2
68064 SM1=(P(I1,5)+SMMIN)**2
68065 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68066 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
68067 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
68068 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
68069 & K(I3M,5).NE.K(I1M,5)) GOTO 360
68071 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
68074 SM3=(P(I3,5)+SMMIN)**2
68075 IF(MSTJ(54).EQ.-2) THEN
68076 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
68077 & S23*MIN(SM1,SM3))*SM1)
68079 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
68080 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
68081 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
68082 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
68084 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
68085 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
68088 IF(WMAX*WI.GE.1.0) GOTO 360
68090 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
68091 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
68092 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
68093 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
68094 & K(I4M,5).NE.K(I1M,5)) GOTO 350
68096 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
68098 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
68099 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
68100 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
68102 IF(MSTJ(54).EQ.-2) THEN
68106 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
68107 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
68108 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
68109 W=MIN(W,MIN(S23,S24)*S13*S14)
68112 C...weight=1-cos(theta)/mtot2
68113 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
68114 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
68115 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
68116 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
68118 IF(W.LE.WMAX) GOTO 350
68120 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
68121 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
68122 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
68123 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
68124 IF(W.LE.WMAX) GOTO 350
68130 IF(MI4.EQ.0) GOTO 380
68133 EOLD=P(I3,4)+P(I4,4)
68135 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
68136 & (P(I3,3)+P(I4,3))**2
68137 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
68138 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
68139 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
68141 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
68142 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
68149 C...Shift momenta and recalculate energies.
68153 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68157 P(I,J)=P(I,J)+P(IM,J)
68159 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68162 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
68167 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
68168 440 ALPHA=(ESUMP-ESUM)/PROD
68169 PARJ(96)=PARJ(96)+ALPHA
68172 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68175 P(I,J)=P(I,J)+ALPHA*V(IM,J)
68177 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68180 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
68183 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
68187 C...Rescale all momenta for energy conservation.
68191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
68193 PQS=PQS+P(I,5)**2/P(I,4)
68196 FAC=(PECM-PQS)/(PES-PQS)
68198 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
68202 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68205 C...Boost back to correct reference frame.
68206 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
68208 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
68214 C*********************************************************************
68217 C...Calculates the momentum shift in a system of two particles assuming
68218 C...the relative momentum squared should be shifted to Q2NEW. NI is the
68219 C...last position occupied in /PYJETS/.
68221 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
68223 C...Double precision and integer declarations.
68224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68225 IMPLICIT INTEGER(I-N)
68226 INTEGER PYK,PYCHGE,PYCOMP
68227 C...Parameter statement to help give large particle numbers.
68228 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68229 &KEXCIT=4000000,KDIMEN=5000000)
68231 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68233 SAVE /PYJETS/,/PYDAT1/
68234 C...Local arrays and data.
68238 IF(MSTJ(55).EQ.0) THEN
68240 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
68241 & (P(I1,3)-P(I2,3))**2
68242 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
68243 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
68247 DA=SE*DE*DP12-DP2*DQ2SE
68248 DB=DP2*DQ2SE-DP12**2
68249 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
68251 PD=HA*(P(I1,J)-P(I2,J))
68263 DP(J)=P(I1,J)+P(I2,J)
68266 C...Boost to cms and rotate first particle to z-axis
68267 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
68268 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
68269 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
68270 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
68271 S=Q2NEW+(P(I1,5)+P(I2,5))**2
68272 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
68276 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
68280 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
68281 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
68282 CALL PYROBO(NI+1,NI+2,THE,PHI,
68283 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
68286 P(NI+1,J)=P(NI+1,J)-P(I1,J)
68287 P(NI+2,J)=P(NI+2,J)-P(I2,J)
68293 C*********************************************************************
68296 C...Gives the mass of a particle/parton.
68298 FUNCTION PYMASS(KF)
68300 C...Double precision and integer declarations.
68301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68302 IMPLICIT INTEGER(I-N)
68303 INTEGER PYK,PYCHGE,PYCOMP
68305 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68306 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68307 SAVE /PYDAT1/,/PYDAT2/
68309 C...Reset variables. Compressed code. Special case for popcorn diquarks.
68318 C...Guarantee use of constituent masses for internal checks.
68319 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
68320 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
68322 PYMASS=PARF(100+KFA)
68323 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
68324 ELSEIF(KFA.LE.10) THEN
68326 ELSEIF(MSTJ(93).EQ.1) THEN
68327 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
68329 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
68332 C...Other masses can be read directly off table.
68337 C...Optional mass broadening according to truncated Breit-Wigner
68338 C...(either in m or in m^2).
68339 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
68340 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
68341 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
68342 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
68345 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
68346 & (PM0*PMAS(KC,2)))
68347 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
68348 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
68349 & (PMUPP-PMLOW)*PYR(0))))
68357 C*********************************************************************
68360 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
68361 C...for Higgs couplings. Everything else sent on to PYMASS.
68363 FUNCTION PYMRUN(KF,Q2)
68365 C...Double precision and integer declarations.
68366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68367 IMPLICIT INTEGER(I-N)
68368 INTEGER PYK,PYCHGE,PYCOMP
68370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68372 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68373 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
68375 C...Most masses not handled here.
68377 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
68380 C...Current-algebra masses, but no Q2 dependence.
68381 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
68382 PYMRUN=PARF(90+KFA)
68384 C...Running current-algebra masses.
68387 PYMRUN=PARF(90+KFA)*
68388 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
68389 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
68395 C*********************************************************************
68398 C...Gives the particle/parton name as a character string.
68400 SUBROUTINE PYNAME(KF,CHAU)
68402 C...Double precision and integer declarations.
68403 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68404 IMPLICIT INTEGER(I-N)
68405 INTEGER PYK,PYCHGE,PYCOMP
68407 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68408 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68409 COMMON/PYDAT4/CHAF(500,2)
68411 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
68412 C...Local character variable.
68415 C...Read out code with distinction particle/antiparticle.
68418 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
68424 C*********************************************************************
68427 C...Gives three times the charge for a particle/parton.
68429 FUNCTION PYCHGE(KF)
68431 C...Double precision and integer declarations.
68432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68433 IMPLICIT INTEGER(I-N)
68434 INTEGER PYK,PYCHGE,PYCOMP
68436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68439 C...Read out charge and change sign for antiparticle.
68442 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
68447 C*********************************************************************
68450 C...Compress the standard KF codes for use in mass and decay arrays;
68451 C...also checks whether a given code actually is defined.
68453 FUNCTION PYCOMP(KF)
68455 C...Double precision and integer declarations.
68456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68457 IMPLICIT INTEGER(I-N)
68458 INTEGER PYK,PYCHGE,PYCOMP
68460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68462 SAVE /PYDAT1/,/PYDAT2/
68463 C...Local arrays and saved data.
68464 DIMENSION KFORD(100:500),KCORD(101:500)
68465 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
68467 C...Whenever necessary reorder codes for faster search.
68468 IF(MSTU(20).EQ.0) THEN
68473 IF(KFA.LE.100) GOTO 120
68475 DO 100 I1=NFORD-1,0,-1
68476 IF(KFA.GE.KFORD(I1)) GOTO 110
68477 KFORD(I1+1)=KFORD(I1)
68478 KCORD(I1+1)=KCORD(I1)
68480 110 KFORD(I1+1)=KFA
68488 C...Fast action if same code as in latest call.
68489 IF(KF.EQ.KFLAST) THEN
68494 C...Starting values. Remove internal diquark flags.
68497 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
68498 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
68500 C...Simple cases: direct translation.
68501 IF(KFA.GT.KFORD(NFORD)) THEN
68502 ELSEIF(KFA.LE.100) THEN
68505 C...Else binary search.
68509 130 IAVG=(IMIN+IMAX)/2
68510 IF(KFORD(IAVG).GT.KFA) THEN
68512 IF(IMAX.GT.IMIN+1) GOTO 130
68513 ELSEIF(KFORD(IAVG).LT.KFA) THEN
68515 IF(IMAX.GT.IMIN+1) GOTO 130
68521 C...Check if antiparticle allowed.
68522 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
68523 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
68526 C...Save codes for possible future fast action.
68533 C*********************************************************************
68536 C...Informs user of errors in program execution.
68538 SUBROUTINE PYERRM(MERR,CHMESS)
68540 C...Double precision and integer declarations.
68541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68542 IMPLICIT INTEGER(I-N)
68543 INTEGER PYK,PYCHGE,PYCOMP
68545 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68547 SAVE /PYJETS/,/PYDAT1/
68548 C...Local character variable.
68549 CHARACTER CHMESS*(*)
68551 C...Write first few warnings, then be silent.
68552 IF(MERR.LE.10) THEN
68553 MSTU(27)=MSTU(27)+1
68555 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
68556 & MERR,MSTU(31),CHMESS
68558 C...Write first few errors, then be silent or stop program.
68559 ELSEIF(MERR.LE.20) THEN
68560 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
68561 MSTU(30)=MSTU(30)+1
68563 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
68564 & MERR-10,MSTU(31),CHMESS
68565 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
68566 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
68567 WRITE(MSTU(11),5200)
68568 IF(MERR.NE.17) CALL PYLIST(2)
68572 C...Stop program in case of irreparable error.
68574 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
68578 C...Formats for output.
68579 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
68580 &' PYEXEC calls:'/5X,A)
68581 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
68582 &' PYEXEC calls:'/5X,A)
68583 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
68585 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
68586 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
68591 C*********************************************************************
68594 C...Calculates the running alpha_electromagnetic.
68596 FUNCTION PYALEM(Q2)
68598 C...Double precision and integer declarations.
68599 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68600 IMPLICIT INTEGER(I-N)
68601 INTEGER PYK,PYCHGE,PYCOMP
68603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68606 C...Calculate real part of photon vacuum polarization.
68607 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
68608 C...For hadrons use parametrization of H. Burkhardt et al.
68609 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
68610 AEMPI=PARU(101)/(3D0*PARU(1))
68611 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
68613 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
68615 ELSEIF(MSTU(101).EQ.2) THEN
68616 RPIGG=1D0-PARU(101)/PARU(103)
68617 ELSEIF(Q2.LT.0.09D0) THEN
68618 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
68619 ELSEIF(Q2.LT.9D0) THEN
68620 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
68621 & 0.00238D0*LOG(1D0+3.927D0*Q2)
68622 ELSEIF(Q2.LT.1D4) THEN
68623 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
68624 & 0.00299D0*LOG(1D0+Q2)
68626 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
68627 & 0.00293D0*LOG(1D0+Q2)
68630 C...Calculate running alpha_em.
68631 PYALEM=PARU(101)/(1D0-RPIGG)
68637 C*********************************************************************
68640 C...Gives the value of alpha_strong.
68642 FUNCTION PYALPS(Q2)
68644 C...Double precision and integer declarations.
68645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68646 IMPLICIT INTEGER(I-N)
68647 INTEGER PYK,PYCHGE,PYCOMP
68649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68651 SAVE /PYDAT1/,/PYDAT2/
68652 C...Coefficients for second-order threshold matching.
68653 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
68654 DIMENSION STEPDN(6),STEPUP(6)
68655 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
68656 c &(2D0*321D0/3703D0),0D0/
68657 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
68658 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
68659 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
68660 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
68662 C...Constant alpha_strong trivial. Pick artificial Lambda.
68663 IF(MSTU(111).LE.0) THEN
68665 MSTU(118)=MSTU(112)
68667 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
68668 & ((33D0-2D0*MSTU(112))*PARU(111)))
68669 PARU(118)=PARU(111)
68673 C...Find effective Q2, number of flavours and Lambda.
68675 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
68678 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
68679 Q2THR=PARU(113)*PMAS(NF,1)**2
68680 IF(Q2EFF.LT.Q2THR) THEN
68683 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
68684 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
68688 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
68689 Q2THR=PARU(113)*PMAS(NF+1,1)**2
68690 IF(Q2EFF.GT.Q2THR) THEN
68693 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
68694 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
68698 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
68699 PARU(117)=SQRT(ALAM2)
68701 C...Evaluate first or second order alpha_strong.
68702 B0=(33D0-2D0*NF)/6D0
68703 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
68704 IF(MSTU(111).EQ.1) THEN
68705 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
68707 B1=(153D0-19D0*NF)/6D0
68708 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
68717 C*********************************************************************
68720 C...Reconstructs an angle from given x and y coordinates.
68722 FUNCTION PYANGL(X,Y)
68724 C...Double precision and integer declarations.
68725 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68726 IMPLICIT INTEGER(I-N)
68727 INTEGER PYK,PYCHGE,PYCOMP
68729 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68734 IF(R.LT.1D-20) RETURN
68735 IF(ABS(X)/R.LT.0.8D0) THEN
68736 PYANGL=SIGN(ACOS(X/R),Y)
68739 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
68740 PYANGL=PARU(1)-PYANGL
68741 ELSEIF(X.LT.0D0) THEN
68742 PYANGL=-PARU(1)-PYANGL
68749 C*********************************************************************
68752 C...Generates random numbers uniformly distributed between
68753 C...0 and 1, excluding the endpoints.
68755 FUNCTION PYR(IDUMMY)
68757 C...Double precision and integer declarations.
68758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68759 IMPLICIT INTEGER(I-N)
68760 INTEGER PYK,PYCHGE,PYCOMP
68762 COMMON/PYDATR/MRPY(6),RRPY(100)
68764 C...Equivalence between commonblock and local variables.
68765 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
68766 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
68767 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
68769 C...Initialize generation from given seed.
68770 IF(MRPY2.EQ.0) THEN
68771 IJ=MOD(MRPY1/30082,31329)
68772 KL=MOD(MRPY1,30082)
68773 I=MOD(IJ/177,177)+2
68775 K=MOD(KL/169,178)+1
68781 M=MOD(MOD(I*J,179)*K,179)
68786 IF(MOD(L*M,64).GE.32) S=S+T
68793 TWOM24=0.5D0*TWOM24
68795 RRPY98=362436D0*TWOM24
68796 RRPY99=7654321D0*TWOM24
68797 RRPY00=16777213D0*TWOM24
68804 C...Generate next random number.
68805 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
68806 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
68809 IF(MRPY4.EQ.0) MRPY4=97
68811 IF(MRPY5.EQ.0) MRPY5=97
68812 RRPY98=RRPY98-RRPY99
68813 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
68815 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
68816 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
68818 C...Update counters. Random number to output.
68820 IF(MRPY3.EQ.1000000000) THEN
68829 C*********************************************************************
68832 C...Dumps the state of the random number generator on a file
68833 C...for subsequent startup from this state onwards.
68835 SUBROUTINE PYRGET(LFN,MOVE)
68837 C...Double precision and integer declarations.
68838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68839 IMPLICIT INTEGER(I-N)
68840 INTEGER PYK,PYCHGE,PYCOMP
68842 COMMON/PYDATR/MRPY(6),RRPY(100)
68844 C...Local character variable.
68847 C...Backspace required number of records (or as many as there are).
68849 NBCK=MIN(MRPY(6),-MOVE)
68851 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
68853 MRPY(6)=MRPY(6)-NBCK
68856 C...Unformatted write on unit LFN.
68857 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
68858 &(RRPY(I2),I2=1,100)
68863 110 WRITE(CHERR,'(I8)') IERR
68864 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
68870 C*********************************************************************
68873 C...Reads a state of the random number generator from a file
68874 C...for subsequent generation from this state onwards.
68876 SUBROUTINE PYRSET(LFN,MOVE)
68878 C...Double precision and integer declarations.
68879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68880 IMPLICIT INTEGER(I-N)
68881 INTEGER PYK,PYCHGE,PYCOMP
68883 COMMON/PYDATR/MRPY(6),RRPY(100)
68885 C...Local character variable.
68888 C...Backspace required number of records (or as many as there are).
68890 NBCK=MIN(MRPY(6),-MOVE)
68892 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
68894 MRPY(6)=MRPY(6)-NBCK
68897 C...Unformatted read from unit LFN.
68900 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
68901 & (RRPY(I2),I2=1,100)
68903 MRPY(6)=MRPY(6)+NFOR
68907 120 WRITE(CHERR,'(I8)') IERR
68908 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
68914 C*********************************************************************
68917 C...Performs rotations and boosts.
68919 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
68921 C...Double precision and integer declarations.
68922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68923 IMPLICIT INTEGER(I-N)
68924 INTEGER PYK,PYCHGE,PYCOMP
68926 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68928 SAVE /PYJETS/,/PYDAT1/
68930 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
68932 C...Find and check range of rotation/boost.
68934 IF(IMIN.LE.0) IMIN=1
68935 IF(MSTU(1).GT.0) IMIN=MSTU(1)
68937 IF(IMAX.LE.0) IMAX=N
68938 IF(MSTU(2).GT.0) IMAX=MSTU(2)
68939 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
68940 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
68944 C...Optional resetting of V (when not set before.)
68945 IF(MSTU(33).NE.0) THEN
68946 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
68954 C...Rotate, typically from z axis to direction (theta,phi).
68955 IF(THE**2+PHI**2.GT.1D-20) THEN
68956 ROT(1,1)=COS(THE)*COS(PHI)
68958 ROT(1,3)=SIN(THE)*COS(PHI)
68959 ROT(2,1)=COS(THE)*SIN(PHI)
68961 ROT(2,3)=SIN(THE)*SIN(PHI)
68966 IF(K(I,1).LE.0) GOTO 140
68972 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
68973 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
68978 C...Boost, typically from rest to momentum/energy=beta.
68979 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
68983 DB=SQRT(DBX**2+DBY**2+DBZ**2)
68985 IF(DB.GT.EPS1) THEN
68986 C...Rescale boost vector if too close to unity.
68987 CALL PYERRM(3,'(PYROBO:) boost vector too large')
68993 DGA=1D0/SQRT(1D0-DB**2)
68995 IF(K(I,1).LE.0) GOTO 160
69000 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
69001 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
69002 P(I,1)=DP(1)+DGABP*DBX
69003 P(I,2)=DP(2)+DGABP*DBY
69004 P(I,3)=DP(3)+DGABP*DBZ
69005 P(I,4)=DGA*(DP(4)+DBP)
69006 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
69007 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
69008 V(I,1)=DV(1)+DGABV*DBX
69009 V(I,2)=DV(2)+DGABV*DBY
69010 V(I,3)=DV(3)+DGABV*DBZ
69011 V(I,4)=DGA*(DV(4)+DBV)
69018 C*********************************************************************
69021 C...Performs global manipulations on the event record, in particular
69022 C...to exclude unstable or undetectable partons/particles.
69024 SUBROUTINE PYEDIT(MEDIT)
69026 C...Double precision and integer declarations.
69027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69028 IMPLICIT INTEGER(I-N)
69029 INTEGER PYK,PYCHGE,PYCOMP
69030 C...Parameter statement to help give large particle numbers.
69031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69032 &KEXCIT=4000000,KDIMEN=5000000)
69034 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69037 COMMON/PYCTAG/NCT,MCT(4000,2)
69038 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
69040 DIMENSION NS(2),PTS(2),PLS(2)
69042 C...Remove unwanted partons/particles.
69043 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
69045 IF(MSTU(2).GT.0) IMAX=MSTU(2)
69046 I1=MAX(1,MSTU(1))-1
69047 DO 110 I=MAX(1,MSTU(1)),IMAX
69048 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
69049 IF(MEDIT.EQ.1) THEN
69050 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69051 ELSEIF(MEDIT.EQ.2) THEN
69052 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69054 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69055 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69056 & K(I,2).EQ.KSUSY1+39) GOTO 110
69057 ELSEIF(MEDIT.EQ.3) THEN
69058 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69060 IF(KC.EQ.0) GOTO 110
69061 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
69062 ELSEIF(MEDIT.EQ.5) THEN
69063 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
69065 IF(KC.EQ.0) GOTO 110
69066 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
69067 & KCHG(KC,2).EQ.0) GOTO 110
69070 C...Pack remaining partons/particles. Origin no longer known.
69079 IF(I1.LT.N) MSTU(3)=0
69080 IF(I1.LT.N) MSTU(70)=0
69083 C...Selective removal of class of entries. New position of retained.
69084 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
69087 K(I,3)=MOD(K(I,3),MSTU(5))
69088 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
69089 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
69090 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
69091 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
69092 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
69093 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
69094 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
69096 K(I,3)=K(I,3)+MSTU(5)*I1
69099 C...Find new event history information and replace old.
69101 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
69102 & K(I,3)/MSTU(5).EQ.0) GOTO 140
69104 130 IM=MOD(K(ID,3),MSTU(5))
69105 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
69106 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
69107 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
69111 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
69112 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
69113 & K(IM,2).EQ.94) THEN
69118 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
69119 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
69120 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
69121 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
69122 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
69123 & K(K(I,4),3)/MSTU(5)
69124 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
69125 & K(K(I,5),3)/MSTU(5)
69127 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
69128 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
69129 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
69130 KCD=MOD(K(I,4),MSTU(5))
69131 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
69132 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
69133 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
69134 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
69135 KCD=MOD(K(I,5),MSTU(5))
69136 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
69137 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
69141 C...Pack remaining entries.
69146 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
69153 C...Also update LHA1 colour tags
69156 K(I1,3)=MOD(K(I1,3),MSTU(5))
69158 IF(I.EQ.MSTU(90+IZ)) THEN
69159 MSTU(90)=MSTU(90)+1
69160 MSTU(90+MSTU(90))=I1
69161 PARU(90+MSTU(90))=PARU(90+IZ)
69165 IF(I1.LT.N) MSTU(3)=0
69166 IF(I1.LT.N) MSTU(70)=0
69169 C...Fill in some missing daughter pointers (lost in colour flow).
69170 ELSEIF(MEDIT.EQ.16) THEN
69172 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
69173 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
69174 C...Find daughters who point to mother.
69176 IF(K(I1,3).NE.I) THEN
69177 ELSEIF(K(I,4).EQ.0) THEN
69183 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69184 IF(K(I,4).NE.0) GOTO 220
69185 C...Find daughters who point to documentation version of mother.
69187 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
69188 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
69189 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
69191 IF(K(I1,3).NE.IM) THEN
69192 ELSEIF(K(I,4).EQ.0) THEN
69198 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69199 IF(K(I,4).NE.0) GOTO 220
69200 C...Find daughters who point to documentation daughters who,
69201 C...in their turn, point to documentation mother.
69205 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
69207 IF(ID1.EQ.IM) ID1=I1
69211 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
69212 ELSEIF(K(I,4).EQ.0) THEN
69218 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69221 C...Save top entries at bottom of PYJETS commonblock.
69222 ELSEIF(MEDIT.EQ.21) THEN
69223 IF(2*N.GE.MSTU(4)) THEN
69224 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
69229 K(MSTU(4)-I,J)=K(I,J)
69230 P(MSTU(4)-I,J)=P(I,J)
69231 V(MSTU(4)-I,J)=V(I,J)
69236 C...Restore bottom entries of commonblock PYJETS to top.
69237 ELSEIF(MEDIT.EQ.22) THEN
69238 DO 260 I=1,MSTU(32)
69240 K(I,J)=K(MSTU(4)-I,J)
69241 P(I,J)=P(MSTU(4)-I,J)
69242 V(I,J)=V(MSTU(4)-I,J)
69247 C...Mark primary entries at top of commonblock PYJETS as untreated.
69248 ELSEIF(MEDIT.EQ.23) THEN
69253 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
69255 IF(KH.NE.0) GOTO 280
69257 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
69258 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
69262 C...Place largest axis along z axis and second largest in xy plane.
69263 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
69264 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
69265 & P(MSTU(61),2)),0D0,0D0,0D0)
69266 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
69267 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
69268 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
69269 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
69270 IF(MEDIT.EQ.31) RETURN
69272 C...Rotate to put slim jet along +z axis.
69279 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
69280 IF(MSTU(41).GE.2) THEN
69282 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69283 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69284 & K(I,2).EQ.KSUSY1+39) GOTO 300
69285 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
69288 IS=2D0-SIGN(0.5D0,P(I,3))
69290 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
69292 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
69293 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
69295 C...Rotate to put second largest jet into -z,+x quadrant.
69297 IF(P(I,3).GE.0D0) GOTO 310
69298 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
69299 IF(MSTU(41).GE.2) THEN
69301 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69302 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69303 & K(I,2).EQ.KSUSY1+39) GOTO 310
69304 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
69307 IS=2D0-SIGN(0.5D0,P(I,1))
69308 PLS(IS)=PLS(IS)-P(I,3)
69310 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
69317 C*********************************************************************
69320 C...Gives program heading, or lists an event, or particle
69321 C...data, or current parameter values.
69323 SUBROUTINE PYLIST(MLIST)
69325 C...Double precision and integer declarations.
69326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69327 IMPLICIT INTEGER(I-N)
69328 INTEGER PYK,PYCHGE,PYCOMP
69329 C...Parameter statement to help give large particle numbers.
69330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69331 &KEXCIT=4000000,KDIMEN=5000000)
69333 C...HEPEVT commonblock.
69334 PARAMETER (NMXHEP=4000)
69335 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
69336 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
69337 DOUBLE PRECISION PHEP,VHEP
69340 C...User process event common block.
69342 PARAMETER (MAXNUP=500)
69343 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
69344 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
69345 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
69346 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
69347 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
69351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69354 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
69355 COMMON/PYCTAG/NCT,MCT(4000,2)
69356 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
69357 C...Local arrays, character variables and data.
69358 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
69360 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
69362 C...Initialization printout: version number and date of last change.
69363 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
69366 IF(MLIST.EQ.0) RETURN
69369 C...List event data, including additional lines after N.
69370 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
69371 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
69372 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
69373 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
69374 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
69376 IF(MLIST.GE.2) LMX=16
69379 IF(MSTU(2).GT.0) IMAX=MSTU(2)
69380 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
69381 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
69382 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
69383 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
69385 C...Get particle name, pad it and check it is not too long.
69386 CALL PYNAME(K(I,2),CHAP)
69389 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
69393 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
69395 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
69398 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
69400 CHAC=CHDL(MDL)(1:2*LDL)//' '
69402 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
69403 & CHDL(MDL)(LDL+1:2*LDL)//' '
69404 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
69408 C...Add information on string connection.
69409 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
69413 IF(KC.NE.0) KCC=KCHG(KC,2)
69414 IF(IABS(K(I,2)).EQ.39) THEN
69415 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
69416 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
69418 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
69419 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
69420 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
69421 ELSEIF(KCC.NE.0) THEN
69423 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
69426 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
69427 & CHAC(LMX-1:LMX-1)='I'
69429 C...Write data for particle/jet.
69430 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
69431 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
69433 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
69434 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
69436 ELSEIF(MLIST.EQ.1) THEN
69437 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
69439 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
69440 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
69441 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
69442 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
69443 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
69445 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
69446 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
69447 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
69448 & ,10000),MCT(I,1),MCT(I,2)
69450 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
69452 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
69453 & ,MCT(I,1),MCT(I,2)
69455 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
69457 C...Insert extra separator lines specified by user.
69458 IF(MSTU(70).GE.1) THEN
69460 DO 110 J=1,MIN(10,MSTU(70))
69461 IF(I.EQ.MSTU(70+J)) ISEP=1
69464 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
69465 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
69466 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
69471 C...Sum of charges and momenta.
69475 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
69476 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
69477 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
69478 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
69479 ELSEIF(MLIST.EQ.1) THEN
69480 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
69481 ELSEIF(MLIST.LE.3) THEN
69482 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
69484 WRITE(MSTU(11),7000) PS(6)
69487 C...Simple listing of HEPEVT entries (mainly for test purposes).
69488 ELSEIF(MLIST.EQ.5) THEN
69489 WRITE(MSTU(11),7100)
69491 IF(ISTHEP(I).EQ.0) GOTO 140
69492 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
69493 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
69497 C...Simple listing of user-process entries (mainly for test purposes).
69498 ELSEIF(MLIST.EQ.7) THEN
69499 WRITE(MSTU(11),7300)
69501 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
69502 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
69505 C...Give simple list of KF codes defined in program.
69506 ELSEIF(MLIST.EQ.11) THEN
69507 WRITE(MSTU(11),7500)
69509 CALL PYNAME(KF,CHAP)
69510 CALL PYNAME(-KF,CHAN)
69511 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
69512 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69516 DO 170 KFLB=1,KFLA-(3-KFLS)/2
69517 KF=1000*KFLA+100*KFLB+KFLS
69518 CALL PYNAME(KF,CHAP)
69519 CALL PYNAME(-KF,CHAN)
69520 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69526 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69527 IF(KMUL.EQ.5) KFLS=5
69529 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
69530 IF(KMUL.EQ.4) KFLR=2
69532 DO 200 KFLC=1,KFLB-1
69533 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
69534 CALL PYNAME(KF,CHAP)
69535 CALL PYNAME(-KF,CHAN)
69536 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69539 CALL PYNAME(KFK,CHAP)
69540 WRITE(MSTU(11),7600) KFK,CHAP
69542 CALL PYNAME(KFK,CHAP)
69543 WRITE(MSTU(11),7600) KFK,CHAP
69546 KF=10000*KFLR+110*KFLB+KFLS
69547 CALL PYNAME(KF,CHAP)
69548 WRITE(MSTU(11),7600) KF,CHAP
69552 CALL PYNAME(KF,CHAP)
69553 WRITE(MSTU(11),7600) KF,CHAP
69555 CALL PYNAME(KF,CHAP)
69556 WRITE(MSTU(11),7600) KF,CHAP
69562 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
69564 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
69565 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
69566 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
69567 CALL PYNAME(KF,CHAP)
69568 CALL PYNAME(-KF,CHAN)
69569 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69576 IF(KF.LT.1000000) GOTO 270
69577 CALL PYNAME(KF,CHAP)
69578 CALL PYNAME(-KF,CHAN)
69579 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
69580 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69583 C...List parton/particle data table. Check whether to be listed.
69584 ELSEIF(MLIST.EQ.12) THEN
69585 WRITE(MSTU(11),7700)
69586 DO 300 KC=1,MSTU(6)
69588 IF(KF.EQ.0) GOTO 300
69589 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
69592 C...Find particle name and mass. Print information.
69593 CALL PYNAME(KF,CHAP)
69594 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
69595 CALL PYNAME(-KF,CHAN)
69596 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
69597 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
69599 C...Particle decay: channel number, branching ratios, matrix element,
69600 C...decay products.
69601 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69603 CALL PYNAME(KFDP(IDC,J),CHAD(J))
69605 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
69610 C...List parameter value table.
69611 ELSEIF(MLIST.EQ.13) THEN
69612 WRITE(MSTU(11),8000)
69614 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
69618 C...Format statements for output on unit MSTU(11) (by default 6).
69619 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
69620 &5X,'KF orig p_x p_y p_z E m'/)
69621 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
69622 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
69623 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
69624 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
69625 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
69626 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
69627 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
69628 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
69629 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
69630 & ,' C tag AC tag'/)
69631 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
69632 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
69633 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
69634 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
69635 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
69636 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
69637 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
69638 6200 FORMAT(66X,5(1X,F12.3))
69639 6300 FORMAT(1X,78('='))
69640 6400 FORMAT(1X,130('='))
69641 6500 FORMAT(1X,65('='))
69642 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
69643 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
69644 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
69645 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
69647 7000 FORMAT(19X,'sum charge:',F6.2)
69648 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
69649 &//' I IST ID Mothers Daughters p_x p_y p_z',
69651 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
69652 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
69653 &//' I IST ID Mothers Colours p_x p_y p_z',
69655 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
69656 7500 FORMAT(///20X,'List of KF codes in program'/)
69657 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
69658 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
69659 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
69660 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
69661 &1X,'ME',3X,'Br.rat.',4X,'decay products')
69662 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
69663 &1X,1P,E13.5,3X,I2)
69664 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
69665 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
69666 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
69667 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
69672 C*********************************************************************
69675 C...Writes a logo for the program.
69679 C...Double precision and integer declarations.
69680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69681 IMPLICIT INTEGER(I-N)
69682 INTEGER PYK,PYCHGE,PYCOMP
69683 C...Parameter for length of information block.
69684 PARAMETER (IREFER=20)
69686 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69687 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69688 SAVE /PYDAT1/,/PYPARS/
69689 C...Local arrays and character variables.
69691 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
69692 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
69694 C...Data on months, logo, titles, and references.
69695 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
69696 &'Oct','Nov','Dec'/
69697 DATA (LOGO(J),J=1,19)/
69699 &' *:::!!:::::::::::* ',
69700 &' *::::::!!::::::::::::::* ',
69701 &' *::::::::!!::::::::::::::::* ',
69702 &' *:::::::::!!:::::::::::::::::* ',
69703 &' *:::::::::!!:::::::::::::::::* ',
69704 &' *::::::::!!::::::::::::::::*! ',
69705 &' *::::::!!::::::::::::::* !! ',
69706 &' !! *:::!!:::::::::::* !! ',
69707 &' !! !* -><- * !! ',
69717 DATA (LOGO(J),J=20,38)/
69718 &'Welcome to the Lund Monte Carlo!',
69720 &'PPP Y Y TTTTT H H III A ',
69721 &'P P Y Y T H H I A A ',
69722 &'PPP Y T HHHHH I AAAAA',
69723 &'P Y T H H I A A',
69724 &'P Y T H H III A A',
69726 &'This is PYTHIA version x.xxx ',
69727 &'Last date of change: xx xxx 200x',
69729 &'Now is xx xxx 200x at xx:xx:xx ',
69731 &'Disclaimer: this program comes ',
69732 &'without any guarantees. Beware ',
69733 &'of errors and use common sense ',
69734 &'when interpreting results. ',
69736 &'Copyright T. Sjostrand (2007) '/
69737 DATA (REFER(J),J=1,14)/
69738 &'An archive of program versions and d',
69739 &'ocumentation is found on the web: ',
69740 &'http://www.thep.lu.se/~torbjorn/Pyth',
69744 &'When you cite this program, the offi',
69745 &'cial reference is to the 6.4 manual:',
69746 &'T. Sjostrand, S. Mrenna and P. Skand',
69747 &'s, JHEP05 (2006) 026 ',
69748 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
69749 &'-T) [hep-ph/0603175]. ',
69752 DATA (REFER(J),J=15,32)/
69753 &'Also remember that the program, to a',
69754 &' large extent, represents original ',
69755 &'physics research. Other publications',
69756 &' of special relevance to your ',
69757 &'studies may therefore deserve separa',
69761 &'Main author: Torbjorn Sjostrand; CER',
69762 &'N/PH, CH-1211 Geneva, Switzerland, ',
69763 &' and Department of Theoretical Phys',
69764 &'ics, Lund University, Lund, Sweden; ',
69765 &' phone: + 41 - 22 - 767 82 27; e-ma',
69766 &'il: torbjorn@thep.lu.se ',
69767 &'Author: Stephen Mrenna; Computing Di',
69768 &'vision, GDS Group, ',
69769 &' Fermi National Accelerator Laborat',
69770 &'ory, MS 234, Batavia, IL 60510, USA;'/
69771 DATA (REFER(J),J=33,2*IREFER)/
69772 &' phone: + 1 - 630 - 840 - 2556; e-m',
69773 &'ail: mrenna@fnal.gov ',
69774 &'Author: Peter Skands; Theoretical Ph',
69775 &'ysics Department, ',
69776 &' Fermi National Accelerator Laborat',
69777 &'ory, MS 106, Batavia, IL 60510, USA;',
69778 &' phone: + 1 - 630 - 840 - 2270; e-m',
69779 &'ail: skands@fnal.gov '/
69781 C...Check that PYDATA linked.
69782 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
69784 & 'Error: PYDATA has not been linked.'
69785 WRITE(*,'(1X,A)') 'Execution stopped!'
69788 C...Write current version number and current date+time.
69790 WRITE(VERS,'(I1)') MSTP(181)
69791 LOGO(28)(24:24)=VERS
69792 WRITE(SUBV,'(I3)') MSTP(182)
69793 LOGO(28)(26:28)=SUBV
69794 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
69795 WRITE(DATE,'(I2)') MSTP(185)
69796 LOGO(29)(22:23)=DATE
69797 LOGO(29)(25:27)=MONTH(MSTP(184))
69798 WRITE(YEAR,'(I4)') MSTP(183)
69799 LOGO(29)(29:32)=YEAR
69801 IF(IDATI(1).LE.0) THEN
69804 WRITE(DATE,'(I2)') IDATI(3)
69806 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
69807 WRITE(YEAR,'(I4)') IDATI(1)
69808 LOGO(31)(15:18)=YEAR
69809 WRITE(HOUR,'(I2)') IDATI(4)
69810 LOGO(31)(23:24)=HOUR
69811 WRITE(MINU,'(I2)') IDATI(5)
69812 LOGO(31)(26:27)=MINU
69813 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
69814 WRITE(SECO,'(I2)') IDATI(6)
69815 LOGO(31)(29:30)=SECO
69816 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
69820 C...Loop over lines in header. Define page feed and side borders.
69821 DO 100 ILIN=1,29+IREFER
69830 C...Separator lines and logos.
69831 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
69832 LINE(4:77)='***********************************************'//
69833 & '***************************'
69834 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
69835 LINE(6:37)=LOGO(ILIN-5)
69836 LINE(44:75)=LOGO(ILIN+14)
69837 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
69838 LINE(5:40)=REFER(2*ILIN-51)
69839 LINE(41:76)=REFER(2*ILIN-50)
69842 C...Write lines to appropriate unit.
69843 WRITE(MSTU(11),'(A79)') LINE
69849 C*********************************************************************
69852 C...Facilitates the updating of particle and decay data
69853 C...by allowing it to be done in an external file.
69855 SUBROUTINE PYUPDA(MUPDA,LFN)
69857 C...Double precision and integer declarations.
69858 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69859 IMPLICIT INTEGER(I-N)
69860 INTEGER PYK,PYCHGE,PYCOMP
69862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69863 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69864 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
69865 COMMON/PYDAT4/CHAF(500,2)
69867 COMMON/PYINT4/MWID(500),WIDS(500,5)
69868 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
69869 C...Local arrays, character variables and data.
69870 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
69871 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
69872 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
69873 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
69874 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
69875 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
69876 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
69878 C...Write header if not yet done.
69879 IF(MSTU(12).NE.12345) CALL PYLIST(0)
69881 C...Write information on file for editing.
69882 IF(MUPDA.EQ.1) THEN
69884 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
69885 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
69886 & MWID(KC),MDCY(KC,1)
69887 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69888 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
69889 & (KFDP(IDC,J),J=1,5)
69893 C...Read complete set of information from edited file or
69894 C...read partial set of new or updated information from edited file.
69895 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
69897 C...Reset counters.
69901 IF(MUPDA.EQ.2) THEN
69906 DO 130 KC=1,MSTU(6)
69907 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
69908 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
69912 C...Begin of loop: read new line; unknown whether particle or
69914 140 READ(LFN,5200,END=190) CHINL
69916 C...Identify particle code and whether already defined (for MUPDA=3).
69917 IF(CHINL(2:10).NE.' ') THEN
69920 IF(MUPDA.EQ.2) THEN
69933 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
69936 C...Remove duplicate old decay data.
69937 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
69938 IDCREP=MDCY(KCREP,2)
69939 NDCREP=MDCY(KCREP,3)
69941 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
69943 DO 180 I=IDCREP,NDC-NDCREP
69944 MDME(I,1)=MDME(I+NDCREP,1)
69945 MDME(I,2)=MDME(I+NDCREP,2)
69946 BRAT(I)=BRAT(I+NDCREP)
69948 KFDP(I,J)=KFDP(I+NDCREP,J)
69953 ELSEIF(KCREP.NE.0) THEN
69961 C...Study line with particle data.
69962 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
69963 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
69964 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
69965 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
69966 & MWID(KC),MDCY(KC,1)
69970 C...Study line with decay data.
69973 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
69974 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
69975 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
69976 MDCY(KC,3)=MDCY(KC,3)+1
69977 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
69978 & (KFDP(NDC,J),J=1,5)
69981 C...End of loop; ensure that PYCOMP tables are updated.
69986 C...Perform possible tests that new information is consistent.
69987 DO 220 KC=1,MSTU(6)
69989 IF(KF.EQ.0) GOTO 220
69990 WRITE(CHKF,5300) KF
69991 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
69992 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
69993 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
69995 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69996 IF(MDME(IDC,2).GT.80) GOTO 210
69998 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
70002 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
70004 ELSEIF(PYCOMP(KP).EQ.0) THEN
70009 PMS=PMS-PMAS(KPC,1)
70010 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
70014 IF(KQ.NE.0) MERR=MAX(2,MERR)
70015 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
70017 IF(MERR.EQ.3) CALL PYERRM(17,
70018 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
70019 IF(MERR.EQ.2) CALL PYERRM(17,
70020 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
70021 IF(MERR.EQ.1) CALL PYERRM(7,
70022 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
70023 BRSUM=BRSUM+BRAT(IDC)
70025 WRITE(CHTMP,5500) BRSUM
70026 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
70027 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
70028 & CHTMP(9:16)//' for KF ='//CHKF)
70031 C...Write DATA statements for inclusion in program.
70032 ELSEIF(MUPDA.EQ.4) THEN
70034 C...Find out how many codes and decay channels are actually used.
70038 IF(KCHG(I,4).NE.0) THEN
70040 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
70044 C...Initialize writing of DATA statements for inclusion in program.
70047 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
70050 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
70054 C...Loop through variables for conversion to characters.
70056 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
70057 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
70058 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
70059 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
70060 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
70061 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
70062 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
70063 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
70064 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
70065 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
70066 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
70067 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
70068 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
70069 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
70070 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
70071 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
70072 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
70073 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
70074 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
70075 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
70076 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
70077 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
70079 C...Replace variables beyond what is properly defined.
70081 IF(IDIM.GT.KCC) CHTMP=' 0'
70082 ELSEIF(IVAR.LE.8) THEN
70083 IF(IDIM.GT.KCC) CHTMP=' 0.0'
70084 ELSEIF(IVAR.LE.11) THEN
70085 IF(IDIM.GT.KCC) CHTMP=' 0'
70086 ELSEIF(IVAR.LE.13) THEN
70087 IF(IDIM.GT.NDC) CHTMP=' 0'
70088 ELSEIF(IVAR.LE.14) THEN
70089 IF(IDIM.GT.NDC) CHTMP=' 0.0'
70090 ELSEIF(IVAR.LE.19) THEN
70091 IF(IDIM.GT.NDC) CHTMP=' 0'
70092 ELSEIF(IVAR.LE.21) THEN
70093 IF(IDIM.GT.KCC) CHTMP=' '
70095 IF(IDIM.GT.KCC) CHTMP=' 0'
70098 C...Length of variable, trailing decimal zeros, quotation marks.
70102 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
70103 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
70105 CHNEW=CHTMP(LLOW:LHIG)//' '
70107 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
70110 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
70111 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
70116 CHNEW(LNEW+1:LNEW+2)='D0'
70119 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
70120 DO 260 LL=LNEW,1,-1
70121 IF(CHNEW(LL:LL).EQ.'''') THEN
70123 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
70129 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
70133 C...Form composite character string, often including repetition counter.
70134 IF(CHNEW.NE.CHOLD) THEN
70141 IF(NRPT.GE.2) LRPT=LNEW+3
70142 IF(NRPT.GE.10) LRPT=LNEW+4
70143 IF(NRPT.GE.100) LRPT=LNEW+5
70144 IF(NRPT.GE.1000) LRPT=LNEW+6
70147 WRITE(CHTMP,5400) NRPT
70149 IF(NRPT.GE.10) LRPT=2
70150 IF(NRPT.GE.100) LRPT=3
70151 IF(NRPT.GE.1000) LRPT=4
70152 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
70156 C...Add characters to end of line, to new line (after storing old line),
70157 C...or to new block of lines (after writing old block).
70158 IF(LLIN+LCOM.LE.70) THEN
70159 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
70161 ELSEIF(NLIN.LE.19) THEN
70162 CHLIN(LLIN+1:72)=' '
70165 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
70168 CHLIN(LLIN:72)='/'//' '
70170 WRITE(CHTMP,5400) IDIM-NRPT
70171 CHBLK(1)(30:33)=CHTMP(13:16)
70173 WRITE(LFN,5700) CHBLK(ILIN)
70177 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
70178 & ',I= , )/'//CHCOM(1:LCOM)//','
70179 WRITE(CHTMP,5400) IDIM-NRPT+1
70180 CHLIN(25:28)=CHTMP(13:16)
70185 C...Write final block of lines.
70186 CHLIN(LLIN:72)='/'//' '
70188 WRITE(CHTMP,5400) NDIM
70189 CHBLK(1)(30:33)=CHTMP(13:16)
70191 WRITE(LFN,5700) CHBLK(ILIN)
70196 C...Formats for reading and writing particle data.
70197 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
70198 5100 FORMAT(10X,2I5,F12.6,5I10)
70209 C*********************************************************************
70212 C...Provides various integer-valued event related data.
70216 C...Double precision and integer declarations.
70217 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70218 IMPLICIT INTEGER(I-N)
70219 INTEGER PYK,PYCHGE,PYCOMP
70221 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70224 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70226 C...Default value. For I=0 number of entries, number of stable entries
70227 C...or 3 times total charge.
70229 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
70230 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
70232 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
70234 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
70235 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
70238 ELSEIF(I.EQ.0) THEN
70240 C...For I > 0 direct readout of K matrix or charge.
70241 ELSEIF(J.LE.5) THEN
70243 ELSEIF(J.EQ.6) THEN
70246 C...Status (existing/fragmented/decayed), parton/hadron separation.
70247 ELSEIF(J.LE.8) THEN
70248 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
70249 IF(J.EQ.8) PYK=PYK*K(I,2)
70250 ELSEIF(J.LE.12) THEN
70254 IF(KC.NE.0) KQ=KCHG(KC,2)
70255 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
70256 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
70258 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
70260 C...Heaviest flavour in hadron/diquark.
70261 ELSEIF(J.EQ.13) THEN
70263 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
70264 IF(KFA.LT.10) PYK=KFA
70265 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
70266 PYK=PYK*ISIGN(1,K(I,2))
70268 C...Particle history: generation, ancestor, rank.
70269 ELSEIF(J.LE.15) THEN
70276 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
70279 ELSEIF(J.EQ.16) THEN
70281 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
70282 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
70289 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
70290 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
70292 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
70293 IF(ILP.EQ.1) GOTO 120
70295 IF(K(I1,1).EQ.12) THEN
70297 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
70298 & .AND.K(I3,2).NE.93) PYK=PYK+1
70304 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
70308 C...Particle coming from collapsing jet system or not.
70309 ELSEIF(J.EQ.17) THEN
70316 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
70317 IF(PYK.EQ.1) PYK=-1
70321 IF(KCHG(KC,2).EQ.0) GOTO 150
70322 IF(K(I1,1).NE.12) PYK=0
70323 IF(K(I1,1).NE.12) RETURN
70326 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
70328 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
70330 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
70332 C...Number of decay products. Colour flow.
70333 ELSEIF(J.EQ.18) THEN
70334 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
70335 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
70336 ELSEIF(J.LE.22) THEN
70337 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
70338 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
70339 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
70340 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
70341 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
70348 C*********************************************************************
70351 C...Provides various real-valued event related data.
70355 C...Double precision and integer declarations.
70356 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70357 IMPLICIT INTEGER(I-N)
70358 INTEGER PYK,PYCHGE,PYCOMP
70360 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70363 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70367 C...Set default value. For I = 0 sum of momenta or charges,
70368 C...or invariant mass of system.
70370 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
70371 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
70373 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
70375 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
70379 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
70383 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70384 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
70386 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
70388 ELSEIF(I.EQ.0) THEN
70390 C...Direct readout of P matrix.
70391 ELSEIF(J.LE.5) THEN
70394 C...Charge, total momentum, transverse momentum, transverse mass.
70395 ELSEIF(J.LE.12) THEN
70396 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
70397 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
70398 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
70399 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
70400 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
70402 C...Theta and phi angle in radians or degrees.
70403 ELSEIF(J.LE.16) THEN
70404 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
70405 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
70406 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
70408 C...True rapidity, rapidity with pion mass, pseudorapidity.
70409 ELSEIF(J.LE.19) THEN
70411 IF(J.EQ.17) PMR=P(I,5)
70412 IF(J.EQ.18) PMR=PYMASS(211)
70413 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
70414 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
70417 C...Energy and momentum fractions (only to be used in CM frame).
70418 ELSEIF(J.LE.25) THEN
70419 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
70420 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
70421 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
70422 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
70423 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
70424 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
70430 C*********************************************************************
70433 C...Performs sphericity tensor analysis to give sphericity,
70434 C...aplanarity and the related event axes.
70436 SUBROUTINE PYSPHE(SPH,APL)
70438 C...Double precision and integer declarations.
70439 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70440 IMPLICIT INTEGER(I-N)
70441 INTEGER PYK,PYCHGE,PYCOMP
70442 C...Parameter statement to help give large particle numbers.
70443 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70444 &KEXCIT=4000000,KDIMEN=5000000)
70446 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70449 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70451 DIMENSION SM(3,3),SV(3,3)
70453 C...Calculate matrix to be diagonalized.
70462 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
70463 IF(MSTU(41).GE.2) THEN
70465 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70466 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70467 & K(I,2).EQ.KSUSY1+39) GOTO 140
70468 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70472 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70474 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
70475 & MAX(1D-10,PA)**(PARU(41)-2D0)
70478 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
70484 C...Very low multiplicities (0 or 1) not considered.
70486 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
70493 SM(J1,J2)=SM(J1,J2)/PS
70497 C...Find eigenvalues to matrix (third degree equation).
70498 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
70499 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
70500 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
70501 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
70502 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
70503 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
70504 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
70505 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
70506 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
70507 IF(P(N+2,4).LT.1D-5) THEN
70508 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
70514 C...Find first and last eigenvector by solving equation system.
70517 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
70519 SV(J1,J2)=SM(J1,J2)
70520 SV(J2,J1)=SM(J1,J2)
70526 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
70529 SMAX=ABS(SV(J1,J2))
70533 DO 220 J3=JA+1,JA+2
70535 RL=SV(J1,JB)/SV(JA,JB)
70537 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
70538 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
70540 SMAX=ABS(SV(J1,J2))
70544 JB2=JB+2-3*((JB+1)/3)
70545 P(N+I,JB1)=-SV(JC,JB2)
70546 P(N+I,JB2)=SV(JC,JB1)
70547 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
70549 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
70550 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70552 P(N+I,J)=SGN*P(N+I,J)/PA
70556 C...Middle axis orthogonal to other two. Fill other codes.
70557 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70558 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
70559 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
70560 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
70573 C...Calculate sphericity and aplanarity. Select storing option.
70574 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
70578 IF(MSTU(43).LE.1) MSTU(3)=3
70579 IF(MSTU(43).GE.2) N=N+3
70584 C*********************************************************************
70587 C...Performs thrust analysis to give thrust, oblateness
70588 C...and the related event axes.
70590 SUBROUTINE PYTHRU(THR,OBL)
70592 C...Double precision and integer declarations.
70593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70594 IMPLICIT INTEGER(I-N)
70595 INTEGER PYK,PYCHGE,PYCOMP
70596 C...Parameter statement to help give large particle numbers.
70597 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70598 &KEXCIT=4000000,KDIMEN=5000000)
70600 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70603 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70605 DIMENSION TDI(3),TPR(3)
70607 C...Take copy of particles that are to be considered in thrust analysis.
70611 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
70612 IF(MSTU(41).GE.2) THEN
70614 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70615 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70616 & K(I,2).EQ.KSUSY1+39) GOTO 100
70617 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70620 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
70621 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
70631 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70633 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
70634 & P(N+NP,4)**(PARU(42)-1D0)
70635 PS=PS+P(N+NP,4)*P(N+NP,5)
70638 C...Very low multiplicities (0 or 1) not considered.
70640 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
70646 C...Loop over thrust and major. T axis along z direction in latter case.
70650 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
70652 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
70653 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
70654 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
70657 C...Find and order particles with highest p (pT for major).
70658 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
70662 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
70663 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
70664 IF(P(I,4).LE.P(ILF,4)) GOTO 140
70666 P(ILF+1,J)=P(ILF,J)
70675 C...Find and order initial axes with highest thrust (major).
70676 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
70679 NC=2**(MIN(MSTU(44),NP)-1)
70684 DO 200 ILF=1,MIN(MSTU(44),NP)
70685 SGN=P(N+NP+ILF+3,5)
70686 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
70688 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
70691 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
70692 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
70693 IF(TDS.LE.P(ILG,4)) GOTO 230
70695 P(ILG+1,J)=P(ILG,J)
70698 ILG=N+NP+MSTU(44)+4
70705 C...Iterate direction of axis until stable maximum.
70712 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
70713 IF(THP.GT.1D-10) TDI(J)=TPR(J)
70717 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
70719 TPR(J)=TPR(J)+SGN*P(I,J)
70722 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
70723 IF(THP.GE.THPS+PARU(48)) GOTO 270
70725 C...Save good axis. Try new initial axis until a number of tries agree.
70726 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
70727 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
70729 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70731 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
70737 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
70740 C...Find minor axis and value by orthogonality.
70741 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70742 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
70743 P(N+NP+3,2)=SGN*P(N+NP+2,1)
70747 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
70752 C...Fill axis information. Rotate back to original coordinate system.
70760 P(N+ILD,J)=P(N+NP+ILD,J)
70764 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
70766 C...Calculate thrust and oblateness. Select storing option.
70768 OBL=P(N+2,4)-P(N+3,4)
70771 IF(MSTU(43).LE.1) MSTU(3)=3
70772 IF(MSTU(43).GE.2) N=N+3
70777 C*********************************************************************
70780 C...Subdivides the particle content of an event into jets/clusters.
70782 SUBROUTINE PYCLUS(NJET)
70784 C...Double precision and integer declarations.
70785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70786 IMPLICIT INTEGER(I-N)
70787 INTEGER PYK,PYCHGE,PYCOMP
70788 C...Parameter statement to help give large particle numbers.
70789 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70790 &KEXCIT=4000000,KDIMEN=5000000)
70792 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70793 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70794 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70795 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70796 C...Local arrays and saved variables.
70798 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
70800 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
70801 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
70802 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
70803 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
70804 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
70805 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
70806 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
70808 C...If first time, reset. If reentering, skip preliminaries.
70809 IF(MSTU(48).LE.0) THEN
70815 PIMASS=PMAS(PYCOMP(211),1)
70818 IF(MSTU(43).GE.2) N=N-NJET
70819 DO 110 I=N+1,N+NJET
70820 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70822 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
70825 R2ACC=PARU(45)*PS(5)**2
70831 C...Find which particles are to be considered in cluster search.
70833 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
70834 IF(MSTU(41).GE.2) THEN
70836 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70837 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70838 & K(I,2).EQ.KSUSY1+39) GOTO 140
70839 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70842 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
70843 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
70848 C...Take copy of these particles, with space left for jets later on.
70854 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
70855 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
70856 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
70857 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70859 PS(J)=PS(J)+P(N+NP,J)
70869 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70871 C...Very low multiplicities not considered.
70872 IF(NP.LT.MSTU(47)) THEN
70873 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
70878 C...Find precluster configuration. If too few jets, make harder cuts.
70880 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
70883 R2ACC=PARU(45)*PS(5)**2
70885 RINIT=1.25D0*PARU(43)
70886 IF(NP.LE.MSTU(47)+2) RINIT=0D0
70887 170 RINIT=0.8D0*RINIT
70890 DO 180 I=N+NP+1,N+2*NP
70894 C...Sum up small momentum region. Jet if enough absolute momentum.
70895 IF(MSTU(46).LE.2) THEN
70899 DO 210 I=N+NP+1,N+2*NP
70900 IF(P(I,5).GT.2D0*RINIT) GOTO 210
70904 P(N+1,J)=P(N+1,J)+P(I,J)
70907 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
70908 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
70909 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
70910 IF(NREM.EQ.0) GOTO 170
70913 C...Find fastest remaining particle.
70916 DO 230 I=N+NP+1,N+2*NP
70917 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
70922 P(N+NPRE,J)=P(IMAX,J)
70927 C...Sum up precluster around it according to pT separation.
70928 IF(MSTU(46).LE.2) THEN
70929 DO 260 I=N+NP+1,N+2*NP
70930 IF(K(I,4).NE.0) GOTO 260
70932 IF(R2.GT.RINIT**2) GOTO 260
70936 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
70939 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
70941 C...Sum up precluster around it according to mass or
70942 C...Durham pT separation.
70946 DO 280 I=N+NP+1,N+2*NP
70947 IF(K(I,4).NE.0) GOTO 280
70948 IF(MSTU(46).LE.4) THEN
70953 IF(R2.GE.R2MIN) GOTO 280
70959 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
70961 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
70968 C...Check if more preclusters to be found. Start over if too few.
70969 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
70970 IF(NREM.GT.0) GOTO 220
70973 C...Reassign all particles to nearest jet. Sum up new jet momenta.
70976 310 IF(MSTU(46).LE.1) THEN
70977 DO 330 I=N+1,N+NJET
70982 DO 360 I=N+NP+1,N+2*NP
70984 DO 340 IJET=N+1,N+NJET
70985 IF(P(IJET,5).LT.RINIT) GOTO 340
70987 IF(R2.GE.R2MIN) GOTO 340
70993 V(IMIN,J)=V(IMIN,J)+P(I,J)
70997 DO 380 I=N+1,N+NJET
71001 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71006 C...Find two closest jets.
71007 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
71008 DO 400 ITRY1=N+1,N+NJET-1
71009 DO 390 ITRY2=ITRY1+1,N+NJET
71010 IF(MSTU(46).LE.2) THEN
71011 R2=R2T(ITRY1,ITRY2)
71012 ELSEIF(MSTU(46).LE.4) THEN
71013 R2=R2M(ITRY1,ITRY2)
71015 R2=R2D(ITRY1,ITRY2)
71017 IF(R2.GE.R2MIN) GOTO 390
71024 C...If allowed, join two closest jets and start over.
71025 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
71026 IREC=MIN(IMIN1,IMIN2)
71027 IDEL=MAX(IMIN1,IMIN2)
71029 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
71031 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
71032 DO 430 I=IDEL+1,N+NJET
71037 IF(MSTU(46).GE.2) THEN
71038 DO 440 I=N+NP+1,N+2*NP
71040 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
71041 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
71047 C...Divide up broad jet if empty cluster in list of final ones.
71048 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
71049 DO 450 I=N+1,N+NJET
71052 DO 460 I=N+NP+1,N+2*NP
71053 K(N+K(I,4),5)=K(N+K(I,4),5)+1
71056 DO 470 I=N+1,N+NJET
71057 IF(K(I,5).EQ.0) IEMP=I
71063 DO 480 I=N+NP+1,N+2*NP
71064 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
71067 IF(R2.LE.R2MAX) GOTO 480
71074 P(IEMP,J)=P(ISPL,J)
71075 P(IJET,J)=P(IJET,J)-P(ISPL,J)
71077 P(IEMP,5)=P(ISPL,5)
71078 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
71079 IF(NLOOP.LE.2) GOTO 300
71084 C...If generalized thrust has not yet converged, continue iteration.
71085 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
71091 C...Reorder jets according to energy.
71092 DO 510 I=N+1,N+NJET
71097 DO 540 INEW=N+1,N+NJET
71099 DO 520 ITRY=N+1,N+NJET
71100 IF(V(ITRY,4).LE.PEMAX) GOTO 520
71109 P(INEW,J)=V(IMAX,J)
71115 C...Clean up particle-jet assignments and jet information.
71116 DO 550 I=N+NP+1,N+2*NP
71119 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
71120 K(IORI,4)=K(IORI,4)+1
71124 DO 570 I=N+1,N+NJET
71127 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
71131 IF(K(I,4).EQ.0) IEMP=I
71134 C...Select storing option. Output variables. Check for failure.
71140 PARU(63)=SQRT(R2MIN)
71141 IF(NJET.LE.1) PARU(63)=0D0
71143 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
71147 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
71148 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
71154 C*********************************************************************
71157 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
71158 C...as used for calorimeters at hadron colliders.
71160 SUBROUTINE PYCELL(NJET)
71162 C...Double precision and integer declarations.
71163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71164 IMPLICIT INTEGER(I-N)
71165 INTEGER PYK,PYCHGE,PYCOMP
71166 C...Parameter statement to help give large particle numbers.
71167 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71168 &KEXCIT=4000000,KDIMEN=5000000)
71170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71172 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71173 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71175 C...Loop over all particles. Find cell that was hit by given particle.
71176 PTLRAT=1D0/SINH(PARU(51))**2
71180 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
71181 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
71182 IF(MSTU(41).GE.2) THEN
71184 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71185 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71186 & K(I,2).EQ.KSUSY1+39) GOTO 110
71187 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71191 PT=SQRT(P(I,1)**2+P(I,2)**2)
71192 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
71193 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
71194 & (ETA/PARU(51)+1D0))))
71195 PHI=PYANGL(P(I,1),P(I,2))
71196 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
71197 & (PHI/PARU(1)+1D0))))
71198 IETPH=MSTU(52)*IETA+IPHI
71200 C...Add to cell already hit, or book new cell.
71202 IF(IETPH.EQ.K(IC,3)) THEN
71208 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
71209 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
71217 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
71218 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
71222 C...Smear true bin content by calorimeter resolution.
71223 IF(MSTU(53).GE.1) THEN
71226 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
71227 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
71228 & COS(PARU(2)*PYR(0))
71229 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
71231 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
71235 C...Remove cells below threshold.
71236 IF(PARU(58).GT.0D0) THEN
71240 IF(P(IC,5).GT.PARU(58)) THEN
71252 C...Find initiator cell: the one with highest pT of not yet used ones.
71256 IF(K(IC,5).NE.2) GOTO 160
71257 IF(P(IC,5).LE.ETMAX) GOTO 160
71263 IF(ETMAX.LT.PARU(52)) GOTO 220
71264 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
71265 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
71279 C...Sum up unused cells within required distance of initiator.
71281 IF(K(IC,5).EQ.0) GOTO 170
71282 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
71283 DPHIA=ABS(P(IC,2)-PHI)
71284 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
71286 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
71287 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
71289 K(NJ,4)=K(NJ,4)+K(IC,4)
71290 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
71291 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
71292 P(NJ,5)=P(NJ,5)+P(IC,5)
71295 C...Reject cluster below minimum ET, else accept.
71296 IF(P(NJ,5).LT.PARU(53)) THEN
71299 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
71301 ELSEIF(MSTU(54).LE.2) THEN
71302 P(NJ,3)=P(NJ,3)/P(NJ,5)
71303 P(NJ,4)=P(NJ,4)/P(NJ,5)
71304 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
71307 IF(K(IC,5).LT.0) K(IC,5)=0
71314 IF(K(IC,5).GE.0) GOTO 210
71315 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
71316 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
71317 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
71318 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
71324 C...Arrange clusters in falling ET sequence.
71325 220 DO 250 I=1,NJ-NC
71328 IF(K(IJ,5).EQ.0) GOTO 230
71329 IF(P(IJ,5).LT.ETMAX) GOTO 230
71337 K(N+I,4)=K(IJMAX,4)
71340 P(N+I,J)=P(IJMAX,J)
71346 C...Convert to massless or massive four-vectors.
71347 IF(MSTU(54).EQ.2) THEN
71348 DO 260 I=N+1,N+NJET
71350 P(I,1)=P(I,5)*COS(P(I,4))
71351 P(I,2)=P(I,5)*SIN(P(I,4))
71352 P(I,3)=P(I,5)*SINH(ETA)
71353 P(I,4)=P(I,5)*COSH(ETA)
71356 ELSEIF(MSTU(54).GE.3) THEN
71357 DO 270 I=N+1,N+NJET
71358 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
71362 C...Information about storage.
71366 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
71367 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
71372 C*********************************************************************
71375 C...Determines, approximately, the two jet masses that minimize
71376 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
71378 SUBROUTINE PYJMAS(PMH,PML)
71380 C...Double precision and integer declarations.
71381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71382 IMPLICIT INTEGER(I-N)
71383 INTEGER PYK,PYCHGE,PYCOMP
71384 C...Parameter statement to help give large particle numbers.
71385 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71386 &KEXCIT=4000000,KDIMEN=5000000)
71388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71393 DIMENSION SM(3,3),SAX(3),PS(3,5)
71406 PIMASS=PMAS(PYCOMP(211),1)
71408 C...Take copy of particles that are to be considered in mass analysis.
71410 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
71411 IF(MSTU(41).GE.2) THEN
71413 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71414 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71415 & K(I,2).EQ.KSUSY1+39) GOTO 170
71416 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71419 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
71420 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
71429 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
71430 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
71431 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
71433 C...Fill information in sphericity tensor and total momentum vector.
71436 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
71439 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71441 PS(3,J)=PS(3,J)+P(N+NP,J)
71445 C...Very low multiplicities (0 or 1) not considered.
71447 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
71452 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
71455 C...Find largest eigenvalue to matrix (third degree equation).
71458 SM(J1,J2)=SM(J1,J2)/PSS
71461 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71462 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71463 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71464 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71465 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71466 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71467 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71469 C...Find largest eigenvector by solving equation system.
71471 SM(J1,J1)=SM(J1,J1)-SMA
71473 SM(J2,J1)=SM(J1,J2)
71479 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
71482 SMAX=ABS(SM(J1,J2))
71486 DO 250 J3=JA+1,JA+2
71488 RL=SM(J1,JB)/SM(JA,JB)
71490 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
71491 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
71493 SMAX=ABS(SM(J1,J2))
71497 JB2=JB+2-3*((JB+1)/3)
71498 SAX(JB1)=-SM(JC,JB2)
71499 SAX(JB2)=SM(JC,JB1)
71500 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
71502 C...Divide particles into two initial clusters by hemisphere.
71504 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
71506 IF(PSAX.LT.0D0) IS=2
71509 PS(IS,J)=PS(IS,J)+P(I,J)
71512 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
71513 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
71515 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
71519 PS(3,J)=PS(1,J)-PS(2,J)
71522 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)
71523 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
71524 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
71525 IF(PMDI.LT.PMD) THEN
71531 C...Loop back if significant reduction in sum of m^2.
71532 IF(PMD.LT.-PARU(48)*PMS) THEN
71536 PS(IS,J)=PS(IS,J)-P(IM,J)
71537 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
71543 C...Final masses and output.
71546 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
71547 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
71548 PMH=MAX(PS(1,5),PS(2,5))
71549 PML=MIN(PS(1,5),PS(2,5))
71554 C*********************************************************************
71557 C...Calculates the first few Fox-Wolfram moments.
71559 SUBROUTINE PYFOWO(H10,H20,H30,H40)
71561 C...Double precision and integer declarations.
71562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71563 IMPLICIT INTEGER(I-N)
71564 INTEGER PYK,PYCHGE,PYCOMP
71565 C...Parameter statement to help give large particle numbers.
71566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71567 &KEXCIT=4000000,KDIMEN=5000000)
71569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71572 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71574 C...Copy momenta for particles and calculate H0.
71579 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
71580 IF(MSTU(41).GE.2) THEN
71582 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71583 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71584 & K(I,2).EQ.KSUSY1+39) GOTO 110
71585 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71588 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
71589 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
71600 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71606 C...Very low multiplicities (0 or 1) not considered.
71608 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
71616 C...Calculate H1 - H4.
71622 DO 120 I2=I1+1,N+NP
71623 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
71624 & (P(I1,4)*P(I2,4))
71625 H10=H10+P(I1,4)*P(I2,4)*CTHE
71626 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
71627 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
71628 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
71633 C...Calculate H1/H0 - H4/H0. Output.
71636 H10=(HD+2D0*H10)/H0
71637 H20=(HD+2D0*H20)/H0
71638 H30=(HD+2D0*H30)/H0
71639 H40=(HD+2D0*H40)/H0
71644 C*********************************************************************
71647 C...Evaluates various properties of an event, with statistics
71648 C...accumulated during the course of the run and
71649 C...printed at the end.
71651 SUBROUTINE PYTABU(MTABU)
71653 C...Double precision and integer declarations.
71654 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71655 IMPLICIT INTEGER(I-N)
71656 INTEGER PYK,PYCHGE,PYCOMP
71657 C...Parameter statement to help give large particle numbers.
71658 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71659 &KEXCIT=4000000,KDIMEN=5000000)
71661 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71664 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71665 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
71666 C...Local arrays, character variables, saved variables and data.
71667 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
71668 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
71669 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
71670 &KFDM(8),KFDC(200,0:8),NPDC(200)
71671 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
71672 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
71673 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
71674 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
71675 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
71676 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
71677 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
71678 &NEVDC/0/,NKFDC/0/,NREDC/0/
71680 C...Reset statistics on initial parton state.
71681 IF(MTABU.EQ.10) THEN
71685 C...Identify and order flavour content of initial state.
71686 ELSEIF(MTABU.EQ.11) THEN
71688 KFM1=2*IABS(MSTU(161))
71689 IF(MSTU(161).GT.0) KFM1=KFM1-1
71690 KFM2=2*IABS(MSTU(162))
71691 IF(MSTU(162).GT.0) KFM2=KFM2-1
71692 KFMN=MIN(KFM1,KFM2)
71693 KFMX=MAX(KFM1,KFM2)
71695 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
71698 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
71699 & KFMX.LT.KFIS(I,2))) THEN
71705 110 IF(IKFIS.LT.0) THEN
71708 IF(NKFIS.GE.100) RETURN
71709 DO 130 I=NKFIS,IKFIS,-1
71710 KFIS(I+1,1)=KFIS(I,1)
71711 KFIS(I+1,2)=KFIS(I,2)
71713 NPIS(I+1,J)=NPIS(I,J)
71723 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
71725 C...Count number of partons in initial state.
71728 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
71729 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
71730 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
71735 IF(IM.LE.0.OR.IM.GT.N) THEN
71737 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
71739 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
71740 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
71750 IF(NP.GE.11) NPCO=8
71751 IF(NP.GE.16) NPCO=9
71752 IF(NP.GE.26) NPCO=10
71753 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
71756 C...Write statistics on initial parton state.
71757 ELSEIF(MTABU.EQ.12) THEN
71758 FAC=1D0/MAX(1,NEVIS)
71759 WRITE(MSTU(11),5000) NEVIS
71762 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
71764 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
71765 CALL PYNAME(KFM1,CHAU)
71767 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
71769 IF(KFIS(I,1).EQ.0) KFMX=0
71771 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
71772 CALL PYNAME(KFM2,CHAU)
71774 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
71775 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
71776 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
71779 C...Copy statistics on initial parton state into /PYJETS/.
71780 ELSEIF(MTABU.EQ.13) THEN
71781 FAC=1D0/MAX(1,NEVIS)
71784 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
71786 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
71788 IF(KFIS(I,1).EQ.0) KFMX=0
71790 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
71797 P(I,J)=FAC*NPIS(I,J)
71798 V(I,J)=FAC*NPIS(I,J+5)
71812 C...Reset statistics on number of particles/partons.
71813 ELSEIF(MTABU.EQ.20) THEN
71820 C...Identify whether particle/parton is primary or not.
71821 ELSEIF(MTABU.EQ.21) THEN
71825 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
71826 MSTU(62)=MSTU(62)+1
71829 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
71831 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
71833 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
71835 ELSEIF(KC.EQ.0) THEN
71836 ELSEIF(K(K(I,3),1).EQ.13) THEN
71838 IF(IM.LE.0.OR.IM.GT.N) THEN
71840 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
71843 ELSEIF(KCHG(KC,2).EQ.0) THEN
71844 KCM=PYCOMP(K(K(I,3),2))
71846 IF(KCHG(KCM,2).NE.0) MPRI=1
71849 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
71850 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
71852 IF(K(I,1).LE.10) THEN
71854 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
71857 C...Fill statistics on number of particles/partons in event.
71859 KFS=3-ISIGN(1,K(I,2))-MPRI
71861 IF(KFA.EQ.KFFS(IP)) THEN
71864 ELSEIF(KFA.LT.KFFS(IP)) THEN
71870 220 IF(IKFFS.LT.0) THEN
71873 IF(NKFFS.GE.400) RETURN
71874 DO 240 IP=NKFFS,IKFFS,-1
71875 KFFS(IP+1)=KFFS(IP)
71877 NPFS(IP+1,J)=NPFS(IP,J)
71886 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
71889 C...Write statistics on particle/parton composition of events.
71890 ELSEIF(MTABU.EQ.22) THEN
71891 FAC=1D0/MAX(1,NEVFS)
71892 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
71894 CALL PYNAME(KFFS(I),CHAU)
71897 IF(KC.NE.0) MDCYF=MDCY(KC,1)
71898 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
71899 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
71902 C...Copy particle/parton composition information into /PYJETS/.
71903 ELSEIF(MTABU.EQ.23) THEN
71904 FAC=1D0/MAX(1,NEVFS)
71910 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
71912 P(I,J)=FAC*NPFS(I,J)
71932 C...Reset factorial moments statistics.
71933 ELSEIF(MTABU.EQ.30) THEN
71939 FM1FM(IM,IB,IP)=0D0
71940 FM2FM(IM,IB,IP)=0D0
71945 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
71946 ELSEIF(MTABU.EQ.31) THEN
71951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
71952 IF(MSTU(41).GE.2) THEN
71954 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71955 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71956 & K(I,2).EQ.KSUSY1+39) GOTO 410
71957 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
71958 & PYCHGE(K(I,2)).EQ.0) GOTO 410
71961 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
71962 IF(MSTU(42).GE.2) PMR=P(I,5)
71963 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71964 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71966 IF(ABS(YETA).GT.PARU(57)) GOTO 410
71967 PHI=PYANGL(P(I,1),P(I,2))
71968 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
71969 IYETA=MAX(0,MIN(511,IYETA))
71970 IPHI=512D0*(PHI+PARU(1))/PARU(2)
71971 IPHI=MAX(0,MIN(511,IPHI))
71974 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
71977 C...Order particles in (pseudo)rapidity and/or azimuth.
71978 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
71979 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
71983 IF(NUPP.EQ.NLOW+1) THEN
71988 DO 350 I1=NUPP-1,NLOW+1,-1
71989 IF(IYETA.GE.K(I1,1)) GOTO 360
71992 360 K(I1+1,1)=IYETA
71993 DO 370 I1=NUPP-1,NLOW+1,-1
71994 IF(IPHI.GE.K(I1,2)) GOTO 380
71998 DO 390 I1=NUPP-1,NLOW+1,-1
71999 IF(IYEP.GE.K(I1,3)) GOTO 400
72009 C...Calculate sum of factorial moments in event.
72017 IF(IM.LE.2) IBIN=2**(10-IB)
72018 IF(IM.EQ.3) IBIN=4**(10-IB)
72019 IAGR=K(NLOW+1,IM)/IBIN
72021 DO 440 I=NLOW+2,NUPP+1
72023 IF(ICUT.EQ.IAGR) THEN
72027 ELSEIF(NAGR.EQ.2) THEN
72028 FEVFM(IB,1)=FEVFM(IB,1)+2D0
72029 ELSEIF(NAGR.EQ.3) THEN
72030 FEVFM(IB,1)=FEVFM(IB,1)+6D0
72031 FEVFM(IB,2)=FEVFM(IB,2)+6D0
72032 ELSEIF(NAGR.EQ.4) THEN
72033 FEVFM(IB,1)=FEVFM(IB,1)+12D0
72034 FEVFM(IB,2)=FEVFM(IB,2)+24D0
72035 FEVFM(IB,3)=FEVFM(IB,3)+24D0
72037 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
72038 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
72039 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
72041 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
72042 & (NAGR-3D0)*(NAGR-4D0)
72050 C...Add results to total statistics.
72053 IF(FEVFM(1,IP).LT.0.5D0) THEN
72055 ELSEIF(IM.LE.2) THEN
72056 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
72058 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
72060 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
72061 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
72065 NMUFM=NMUFM+(NUPP-NLOW)
72068 C...Write accumulated statistics on factorial moments.
72069 ELSEIF(MTABU.EQ.32) THEN
72070 FAC=1D0/MAX(1,NEVFM)
72071 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
72072 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
72073 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
72075 WRITE(MSTU(11),5500)
72078 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
72080 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
72081 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
72082 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
72084 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
72085 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
72088 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
72093 C...Copy statistics on factorial moments into /PYJETS/.
72094 ELSEIF(MTABU.EQ.33) THEN
72095 FAC=1D0/MAX(1,NEVFM)
72102 IF(IM.NE.2) K(I,3)=2**(IB-1)
72104 IF(IM.NE.1) K(I,4)=2**(IB-1)
72106 P(I,1)=2D0*PARU(57)/K(I,3)
72107 V(I,1)=PARU(2)/K(I,4)
72109 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
72110 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
72126 C...Reset statistics on Energy-Energy Correlation.
72127 ELSEIF(MTABU.EQ.40) THEN
72138 C...Find particles to include, with proper assumed mass.
72139 ELSEIF(MTABU.EQ.41) THEN
72145 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
72146 IF(MSTU(41).GE.2) THEN
72148 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72149 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72150 & K(I,2).EQ.KSUSY1+39) GOTO 570
72151 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
72152 & PYCHGE(K(I,2)).EQ.0) GOTO 570
72155 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
72156 IF(MSTU(42).GE.2) PMR=P(I,5)
72157 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
72158 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
72165 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72166 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
72169 IF(NUPP.EQ.NLOW) RETURN
72171 C...Analyze Energy-Energy Correlation in event.
72172 FAC=(2D0/ECM**2)*50D0/PARU(1)
72176 DO 600 I1=NLOW+2,NUPP
72177 DO 590 I2=NLOW+1,I1-1
72178 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72179 & (P(I1,5)*P(I2,5))
72180 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
72181 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
72182 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
72186 FE1EC(J)=FE1EC(J)+FEVEE(J)
72187 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
72188 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
72189 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
72190 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
72191 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
72195 C...Write statistics on Energy-Energy Correlation.
72196 ELSEIF(MTABU.EQ.42) THEN
72197 FAC=1D0/MAX(1,NEVEE)
72198 WRITE(MSTU(11),5700) NEVEE
72201 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
72202 FEEC2=FAC*FE1EC(51-J)
72203 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
72205 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
72206 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
72207 & FEEC2,FEES2,FEECA,FEESA
72210 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
72211 ELSEIF(MTABU.EQ.43) THEN
72212 FAC=1D0/MAX(1,NEVEE)
72219 P(I,1)=FAC*FE1EC(I)
72220 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
72221 P(I,2)=FAC*FE1EC(51-I)
72222 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
72223 P(I,3)=FAC*FE1EA(I)
72224 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
72225 P(I,4)=PARU(1)*(I-1)/50D0
72226 P(I,5)=PARU(1)*I/50D0
72241 C...Reset statistics on decay channels.
72242 ELSEIF(MTABU.EQ.50) THEN
72247 C...Identify and order flavour content of final state.
72248 ELSEIF(MTABU.EQ.51) THEN
72252 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
72259 IF(K(I,2).LT.0) KFM=KFM-1
72260 DO 650 IDS=NDS-1,1,-1
72262 IF(KFM.LT.KFDM(IDS)) GOTO 660
72263 KFDM(IDS+1)=KFDM(IDS)
72269 C...Find whether old or new final state.
72271 IF(NDS.LT.KFDC(IDC,0)) THEN
72274 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
72276 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
72279 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
72288 700 IF(IKFDC.LT.0) THEN
72290 ELSEIF(NKFDC.GE.200) THEN
72294 DO 720 IDC=NKFDC,IKFDC,-1
72295 NPDC(IDC+1)=NPDC(IDC)
72297 KFDC(IDC+1,I)=KFDC(IDC,I)
72303 KFDC(IKFDC,I)=KFDM(I)
72307 NPDC(IKFDC)=NPDC(IKFDC)+1
72309 C...Write statistics on decay channels.
72310 ELSEIF(MTABU.EQ.52) THEN
72311 FAC=1D0/MAX(1,NEVDC)
72312 WRITE(MSTU(11),5900) NEVDC
72314 DO 740 I=1,KFDC(IDC,0)
72317 IF(2*KF.NE.KFM) KF=-KF
72318 CALL PYNAME(KF,CHAU)
72320 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
72322 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
72324 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
72326 C...Copy statistics on decay channels into /PYJETS/.
72327 ELSEIF(MTABU.EQ.53) THEN
72328 FAC=1D0/MAX(1,NEVDC)
72334 K(IDC,5)=KFDC(IDC,0)
72339 DO 770 I=1,KFDC(IDC,0)
72342 IF(2*KF.NE.KFM) KF=-KF
72343 IF(I.LE.5) P(IDC,I)=KF
72344 IF(I.GE.6) V(IDC,I-5)=KF
72346 V(IDC,5)=FAC*NPDC(IDC)
72361 C...Format statements for output on unit MSTU(11) (default 6).
72362 5000 FORMAT(///20X,'Event statistics - initial state'/
72363 &20X,'based on an analysis of ',I6,' events'//
72364 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
72365 &'according to fragmenting system multiplicity'/
72366 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
72367 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
72368 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
72369 5200 FORMAT(///20X,'Event statistics - final state'/
72370 &20X,'based on an analysis of ',I7,' events'//
72371 &5X,'Mean primary multiplicity =',F10.4/
72372 &5X,'Mean final multiplicity =',F10.4/
72373 &5X,'Mean charged multiplicity =',F10.4//
72374 &5X,'Number of particles produced per event (directly and via ',
72375 &'decays/branchings)'/
72376 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
72377 &8X,'Total'/35X,'prim seco prim seco'/)
72378 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
72379 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
72380 &20X,'based on an analysis of ',I6,' events'//
72381 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
72382 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
72384 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
72385 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
72386 &20X,'based on an analysis of ',I6,' events'//
72387 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
72388 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
72389 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
72390 5900 FORMAT(///20X,'Decay channel analysis - final state'/
72391 &20X,'based on an analysis of ',I6,' events'//
72392 &2X,'Probability',10X,'Complete final state'/)
72393 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
72394 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
72395 &'or table overflow)')
72400 C*********************************************************************
72403 C...Handles the generation of an e+e- annihilation jet event.
72405 SUBROUTINE PYEEVT(KFL,ECM)
72407 C...Double precision and integer declarations.
72408 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72409 IMPLICIT INTEGER(I-N)
72410 INTEGER PYK,PYCHGE,PYCOMP
72412 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72413 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72414 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72415 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72417 C...Check input parameters.
72418 IF(MSTU(12).NE.12345) CALL PYLIST(0)
72419 IF(KFL.LT.0.OR.KFL.GT.8) THEN
72420 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
72421 IF(MSTU(21).GE.1) RETURN
72423 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
72424 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
72425 IF(ECM.LT.ECMMIN) THEN
72426 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
72427 IF(MSTU(21).GE.1) RETURN
72430 C...Check consistency of MSTJ options set.
72431 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
72433 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
72436 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
72438 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
72442 C...Initialize alpha_strong and total cross-section.
72443 MSTU(111)=MSTJ(108)
72444 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
72446 PARU(112)=PARJ(121)
72447 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
72448 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
72449 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
72451 IF(MSTJ(116).GE.3) MSTJ(116)=1
72454 C...Add initial e+e- to event record (documentation only).
72457 IF(NTRY.GT.100) THEN
72458 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
72463 IF(MSTJ(115).GE.2) THEN
72465 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
72467 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
72471 C...Radiative photon (in initial state).
72474 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
72476 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
72477 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
72479 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
72480 K(NC,3)=MIN(MSTJ(115)/2,1)
72483 C...Virtual exchange boson (gamma or Z0).
72484 IF(MSTJ(115).GE.3) THEN
72487 IF(MSTJ(102).EQ.2) KF=23
72491 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
72497 C...Choice of flavour and jet configuration.
72498 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
72499 IF(KFLC.EQ.0) GOTO 100
72500 CALL PYXJET(ECMC,NJET,CUT)
72502 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
72504 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
72505 IF(NJET.EQ.2) MSTJ(120)=1
72507 C...Fill jet configuration and origin.
72508 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
72509 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
72511 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
72512 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
72513 &-KFLC,ECMC,X1,X2,X4,X12,X14)
72514 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
72515 &-KFLC,ECMC,X1,X2,X4,X12,X14)
72516 IF(MSTU(24).NE.0) GOTO 100
72518 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
72521 C...Angular orientation according to matrix element.
72522 IF(MSTJ(106).EQ.1) THEN
72523 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
72524 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
72525 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
72528 C...Rotation and boost from radiative photon.
72530 DBEK=-PAK/(ECM-PAK)
72531 NMIN=NC+1-MSTJ(115)/3
72532 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
72533 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
72534 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
72537 C...Generate parton shower. Rearrange along strings and check.
72538 IF(MSTJ(101).EQ.5) THEN
72539 CALL PYSHOW(N-1,N,ECMC)
72541 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
72542 IF(MSTJ(105).GE.0) MSTU(28)=0
72545 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
72548 C...Fragmentation/decay generation. Information for PYTABU.
72549 IF(MSTJ(105).EQ.1) CALL PYEXEC
72556 C*********************************************************************
72559 C...Calculates total cross-section, including initial state
72560 C...radiation effects.
72562 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
72564 C...Double precision and integer declarations.
72565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72566 IMPLICIT INTEGER(I-N)
72567 INTEGER PYK,PYCHGE,PYCOMP
72569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72570 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72571 SAVE /PYDAT1/,/PYDAT2/
72573 C...Status, (optimized) Q^2 scale, alpha_strong.
72575 MSTJ(119)=10*MSTJ(102)+KFL
72576 IF(MSTJ(111).EQ.0) THEN
72578 ELSEIF(MSTU(111).EQ.0) THEN
72579 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
72580 & ((33D0-2D0*MSTU(112))*PARU(111)))))
72581 Q2R=PARJ(168)*ECM**2
72583 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
72584 & (2D0*PARU(112)/ECM)**2))
72585 Q2R=PARJ(168)*ECM**2
72587 ALSPI=PYALPS(Q2R)/PARU(1)
72589 C...QCD corrections factor in R.
72590 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
72592 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
72594 ELSEIF(MSTJ(109).EQ.0) THEN
72595 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
72596 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
72597 & LOG(PARJ(168))*ALSPI**2)
72598 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
72599 RQCD=1D0+(3D0/4D0)*ALSPI
72601 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
72604 C...Calculate Z0 width if default value not acceptable.
72605 IF(MSTJ(102).GE.3) THEN
72606 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
72607 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
72610 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
72611 & (2D0*PYMASS(KFLC)/ ECM)**2))
72612 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
72613 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
72614 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
72616 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
72620 C...Calculate propagator and related constants for QFD case.
72621 POLL=1D0-PARJ(131)*PARJ(132)
72622 IF(MSTJ(102).GE.2) THEN
72623 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
72624 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
72625 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
72626 VE=4D0*PARU(102)-1D0
72627 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
72628 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
72633 C...Loop over different flavours: charge, velocity.
72638 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
72639 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
72642 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
72643 QF=KCHG(KFLC,1)/3D0
72645 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
72647 C...Calculate R and sum of charges for QED or QFD case.
72648 RQQ=RQQ+3D0*QF**2*POLL
72649 IF(MSTJ(102).LE.1) THEN
72650 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
72652 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
72653 RQV=RQV-6D0*QF*VF*SF1I
72654 RVA=RVA+3D0*(VF**2+1D0)*SF1W
72655 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
72656 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
72660 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
72662 C...Calculate cross-section, including QCD corrections.
72665 PARJ(143)=RTOT*RQCD
72666 PARJ(144)=PARJ(143)
72667 PARJ(145)=PARJ(141)*86.8D0/ECM**2
72668 PARJ(146)=PARJ(142)*86.8D0/ECM**2
72669 PARJ(147)=PARJ(143)*86.8D0/ECM**2
72670 PARJ(148)=PARJ(147)
72671 PARJ(157)=RSUM*RQCD
72675 IF(MSTJ(107).LE.0) RETURN
72677 C...Virtual cross-section.
72679 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
72680 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
72681 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
72682 &1.526D0*LOG(ECM**2/0.932D0)
72684 C...Soft and hard radiative cross-section in QED case.
72685 IF(MSTJ(102).LE.1) THEN
72686 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
72687 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
72688 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
72690 C...Soft and hard radiative cross-section in QFD case.
72692 SZM=1D0-(PARJ(123)/ECM)**2
72693 SZW=PARJ(123)*PARJ(124)/ECM**2
72694 PARJ(161)=-RQQ/RSUM
72695 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
72696 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
72697 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
72698 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
72699 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
72700 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
72701 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
72702 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
72703 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
72704 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
72705 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
72706 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
72707 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
72710 C...Total cross-section and fraction of hard photon events.
72711 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
72712 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
72713 PARJ(144)=PARJ(157)
72714 PARJ(148)=PARJ(144)*86.8D0/ECM**2
72720 C*********************************************************************
72723 C...Generates initial state photon radiation.
72725 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
72727 C...Double precision and integer declarations.
72728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72729 IMPLICIT INTEGER(I-N)
72730 INTEGER PYK,PYCHGE,PYCOMP
72732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72735 C...Function: cumulative hard photon spectrum in QFD case.
72736 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
72737 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
72739 C...Determine whether radiative photon or not.
72742 IF(PARJ(160).LT.PYR(0)) RETURN
72745 C...Photon energy range. Find photon momentum in QED case.
72747 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
72748 IF(MSTJ(102).LE.1) THEN
72749 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
72750 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
72752 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
72754 SZM=1D0-(PARJ(123)/ECM)**2
72755 SZW=PARJ(123)*PARJ(124)/ECM**2
72758 FXKD=1D-4*(FXKU-FXKL)
72759 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
72764 IF(FXKV.GT.FXKR) THEN
72771 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
72772 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
72776 C...Photon polar and azimuthal angle.
72777 PME=2D0*(PYMASS(11)/ECM)**2
72778 120 CTHM=PME*(2D0/PME)**PYR(0)
72779 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
72780 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
72782 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
72783 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
72784 THEK=PYANGL(CTHE,STHE)
72785 PHIK=PARU(2)*PYR(0)
72787 C...Rotation angle for hadronic system.
72789 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
72791 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
72792 &(2D0-XK*(1D0-SGN*CTHE)))
72797 C*********************************************************************
72800 C...Selects flavour for produced qqbar pair.
72802 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
72804 C...Double precision and integer declarations.
72805 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72806 IMPLICIT INTEGER(I-N)
72807 INTEGER PYK,PYCHGE,PYCOMP
72809 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72810 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72811 SAVE /PYDAT1/,/PYDAT2/
72813 C...Calculate maximum weight in QED or QFD case.
72814 IF(MSTJ(102).LE.1) THEN
72817 POLL=1D0-PARJ(131)*PARJ(132)
72818 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
72819 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
72820 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
72821 VE=4D0*PARU(102)-1D0
72822 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
72823 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
72824 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
72825 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
72826 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
72830 C...Choose flavour. Gives charge and velocity.
72833 IF(NTRY.GT.100) THEN
72834 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
72839 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
72842 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
72843 QF=KCHG(KFLC,1)/3D0
72845 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
72847 C...Calculate weight in QED or QFD case.
72848 IF(MSTJ(102).LE.1) THEN
72850 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
72852 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
72853 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
72854 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
72856 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
72859 C...Weighting or new event (radiative photon). Cross-section update.
72860 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
72861 PARJ(158)=PARJ(158)+1D0
72862 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
72863 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
72864 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
72865 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
72866 PARJ(148)=PARJ(144)*86.8D0/ECM**2
72871 C*********************************************************************
72874 C...Selects number of jets in matrix element approach.
72876 SUBROUTINE PYXJET(ECM,NJET,CUT)
72878 C...Double precision and integer declarations.
72879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72880 IMPLICIT INTEGER(I-N)
72881 INTEGER PYK,PYCHGE,PYCOMP
72883 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72885 C...Local array and data.
72887 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
72889 C...Trivial result for two-jets only, including parton shower.
72890 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
72893 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
72894 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
72896 IF(MSTJ(109).EQ.2) CF=1D0
72897 IF(MSTJ(111).EQ.0) THEN
72900 ELSEIF(MSTU(111).EQ.0) THEN
72901 PARJ(169)=MIN(1D0,PARJ(129))
72902 Q2=PARJ(169)*ECM**2
72903 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
72904 & ((33D0-2D0*MSTU(112))*PARU(111)))))
72905 Q2R=PARJ(168)*ECM**2
72907 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
72908 Q2=PARJ(169)*ECM**2
72909 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
72910 & (2D0*PARU(112)/ECM)**2))
72911 Q2R=PARJ(168)*ECM**2
72914 C...alpha_strong for R and R itself.
72915 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
72916 IF(IABS(MSTJ(101)).EQ.1) THEN
72918 ELSEIF(MSTJ(109).EQ.0) THEN
72919 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
72920 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
72921 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
72923 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
72926 C...alpha_strong for jet rate. Initial value for y cut.
72927 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
72928 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
72929 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
72930 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
72931 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
72933 C...Parametrization of first order three-jet cross-section.
72934 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
72937 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
72938 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
72939 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
72940 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
72941 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
72945 C...Parametrization of second order three-jet cross-section.
72946 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
72947 & CUT.GE.0.25D0) THEN
72949 ELSEIF(MSTJ(110).LE.1) THEN
72950 CT=LOG(1D0/CUT-2D0)
72951 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
72952 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
72954 C...Interpolation in second/first order ratio for Zhu parametrization.
72955 ELSEIF(MSTJ(110).EQ.2) THEN
72958 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
72964 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
72966 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
72969 C...Shift in second order three-jet cross-section with optimized Q^2.
72970 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
72971 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
72972 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
72974 C...Parametrization of second order four-jet cross-section.
72975 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
72978 CT=LOG(1D0/CUT-5D0)
72979 IF(CUT.LE.0.018D0) THEN
72980 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
72981 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
72983 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
72984 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
72986 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
72987 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
72988 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
72989 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
72990 & 0.002093D0*CT**3)
72991 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
72993 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
72994 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
72997 C...If negative three-jet rate, change y' optimization parameter.
72998 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
72999 & PARJ(169).LT.0.99D0) THEN
73000 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
73001 Q2=PARJ(169)*ECM**2
73002 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
73006 C...If too high cross-section, use harder cuts, or fail.
73007 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
73008 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
73009 & PARJ(169).LT.0.99D0) THEN
73010 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
73011 Q2=PARJ(169)*ECM**2
73012 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
73014 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
73016 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
73018 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
73019 & PARJ(154))**(-1D0/3D0)
73020 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
73024 C...Scalar gluon (first order only).
73026 ALSPI=PYALPS(ECM**2)/PARU(1)
73027 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
73029 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
73030 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
73035 C...Select number of jets.
73037 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
73039 ELSEIF(MSTJ(101).LE.0) THEN
73040 NJET=MIN(4,2-MSTJ(101))
73044 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
73045 IF(PARJ(154).GT.RNJ) NJET=4
73051 C*********************************************************************
73054 C...Selects the kinematical variables of three-jet events.
73056 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
73058 C...Double precision and integer declarations.
73059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73060 IMPLICIT INTEGER(I-N)
73061 INTEGER PYK,PYCHGE,PYCOMP
73063 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73066 DIMENSION ZHUP(5,12)
73068 C...Coefficients of Zhu second order parametrization.
73069 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
73070 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
73071 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
73072 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
73073 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
73074 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
73075 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
73076 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
73077 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
73078 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
73079 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
73081 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
73082 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
73085 C...Event type. Mass effect factors and other common constants.
73089 QME=(2D0*PMQ/ECM)**2
73090 IF(MSTJ(109).NE.1) THEN
73092 CUTD=LOG(1D0/CUT-2D0)
73093 IF(MSTJ(109).EQ.0) THEN
73097 WTMX=MIN(20D0,37D0-6D0*CUTD)
73098 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
73106 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
73107 ALS2PI=PARU(118)/PARU(2)
73109 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
73110 & LOG(PARJ(169))*ALS2PI
73111 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
73113 C...Choose three-jet events in allowed region.
73115 110 Y13L=CUTL+CUTD*PYR(0)
73116 Y23L=CUTL+CUTD*PYR(0)
73120 IF(Y12.LE.CUT) GOTO 110
73121 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
73123 C...Second order corrections.
73124 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
73129 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
73130 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
73131 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
73132 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
73133 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
73134 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
73135 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
73136 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
73137 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
73138 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
73139 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
73140 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
73141 & TR*(2D0*CUTL/3D0-10D0/9D0)+
73142 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
73143 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
73144 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
73145 & Y13*Y23)/(Y12+Y13)**2)/WT1+
73146 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
73147 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
73148 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
73149 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
73150 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
73151 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
73152 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
73153 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
73154 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
73155 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
73157 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
73158 C...Second order corrections; Zhu parametrization of ERT.
73163 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
73167 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73168 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73169 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73170 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73173 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73174 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73175 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73176 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73178 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73179 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73180 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73181 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73182 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
73184 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
73185 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
73186 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
73189 C...Impose mass cuts (gives two jets). For fixed jet number new try.
73193 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
73194 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
73195 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
73196 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
73197 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
73199 C...Scalar gluon model (first order only, no mass effects).
73202 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
73203 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
73204 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
73205 X1=1D0-0.5D0*(X3+YD)
73206 X2=1D0-0.5D0*(X3-YD)
73207 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
73208 IF(MSTJ(102).GE.2) THEN
73209 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
73210 & X3**2*PYR(0)) NJET=2
73212 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
73218 C*********************************************************************
73221 C...Selects the kinematical variables of four-jet events.
73223 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
73225 C...Double precision and integer declarations.
73226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73227 IMPLICIT INTEGER(I-N)
73228 INTEGER PYK,PYCHGE,PYCOMP
73230 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73233 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
73235 C...Common constants. Colour factors for QCD and Abelian gluon theory.
73237 QME=(2D0*PMQ/ECM)**2
73238 CT=LOG(1D0/CUT-5D0)
73239 IF(MSTJ(109).EQ.0) THEN
73249 C...Choice of process (qqbargg or qqbarqqbar).
73252 IF(PARJ(155).GT.PYR(0)) IT=2
73253 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
73254 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
73255 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
73256 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
73259 C...Sample the five kinematical variables (for qqgg preweighted in y34).
73260 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
73261 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
73262 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
73263 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
73264 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
73266 CP=COS(PARU(1)*PYR(0))
73269 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
73270 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
73271 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
73273 Y12=1D0-Y134-Y23-Y24
73274 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
73278 C...Calculate matrix elements for qqgg or qqqq process.
73283 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
73284 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
73285 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
73286 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
73287 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
73288 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
73289 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
73290 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
73291 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
73292 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
73293 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
73294 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
73295 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
73296 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
73297 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
73298 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
73299 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
73300 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
73301 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
73302 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
73303 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
73304 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
73305 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
73306 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
73307 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
73308 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
73309 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
73310 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
73311 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
73312 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
73313 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
73314 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
73315 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
73316 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
73317 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
73318 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
73319 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
73320 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
73321 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
73322 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
73323 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
73326 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
73327 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
73328 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
73329 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
73330 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
73331 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
73332 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
73333 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
73334 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
73335 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
73336 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
73337 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
73338 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
73339 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
73340 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
73341 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
73342 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
73343 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
73346 C...Permutations of momenta in matrix element. Weighting.
73347 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
73358 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
73369 IF(IC.LE.3) GOTO 120
73370 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
73373 C...qqgg events: string configuration and event type.
73375 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
73376 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
73377 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
73378 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
73379 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
73380 IF(ID.EQ.2) GOTO 130
73381 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
73382 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
73383 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
73384 IF(ID.EQ.2) GOTO 130
73387 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
73388 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
73391 C...Mass cuts. Kinematical variables out.
73392 IF(Y12.LE.CUT+QME) NJET=2
73393 IF(NJET.EQ.2) GOTO 150
73394 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
73395 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
73396 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
73398 X12=(1D0-Q12)*Y13+Q12*Y23
73400 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
73402 C...qqbarqqbar events: string configuration, choose new flavour.
73405 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
73406 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
73407 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
73408 IF(WTR.LT.WTD(4)) ID=4
73409 IF(ID.GE.2) GOTO 130
73412 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
73413 140 KFLN=1+INT(5D0*PYR(0))
73414 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
73415 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
73416 IF(KFLN.GT.MSTJ(104)) NJET=2
73418 QMEN=(2D0*PMQN/ECM)**2
73420 C...Mass cuts. Kinematical variables out.
73421 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
73422 IF(NJET.EQ.2) GOTO 150
73423 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
73424 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
73425 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
73426 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
73427 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
73428 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
73431 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
73433 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
73434 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
73435 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
73437 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
73442 C*********************************************************************
73445 C...Gives the angular orientation of events.
73447 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
73449 C...Double precision and integer declarations.
73450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73451 IMPLICIT INTEGER(I-N)
73452 INTEGER PYK,PYCHGE,PYCOMP
73454 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73455 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73456 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73457 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73459 C...Charge. Factors depending on polarization for QED case.
73461 POLL=1D0-PARJ(131)*PARJ(132)
73462 POLD=PARJ(132)-PARJ(131)
73463 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
73469 C...Factors depending on flavour, energy and polarization for QFD case.
73471 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73472 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73473 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73475 VE=4D0*PARU(102)-1D0
73477 VF=AF-4D0*QF*PARU(102)
73478 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
73479 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
73480 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
73481 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
73482 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
73483 & SFW*SFF**2*(VE**2-AE**2))
73484 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
73488 C...Mass factor. Differential cross-sections for two-jet events.
73491 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
73492 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
73494 SIGU=4D0*SQRT(1D0-QME)
73495 SIGL=2D0*QME*SQRT(1D0-QME)
73501 C...Kinematical variables. Reduce four-jet event to three-jet one.
73504 X1=2D0*P(NC+1,4)/ECM
73505 X2=2D0*P(NC+3,4)/ECM
73507 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
73508 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
73509 X1=2D0*P(NC+1,4)/ECMR
73510 X2=2D0*P(NC+4,4)/ECMR
73513 C...Differential cross-sections for three-jet (or reduced four-jet).
73514 XQ=(1D0-X1)/(1D0-X2)
73515 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
73516 ST12=SQRT(1D0-CT12**2)
73517 IF(MSTJ(109).NE.1) THEN
73518 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
73519 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
73520 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
73521 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
73523 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
73524 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
73525 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
73526 SIGA=X2**2*ST12/SQ2
73527 SIGP=2D0*(X1**2-X2**2*CT12)
73529 C...Differential cross-sect for scalar gluons (no mass effects).
73533 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
73534 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
73535 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
73536 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
73537 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
73538 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
73539 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
73540 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
73541 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
73542 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
73543 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
73547 C...Upper bounds for differential cross-section.
73552 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
73553 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
73554 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
73555 &2D0*HF2A*ABS(SIGP)
73557 C...Generate angular orientation according to differential cross-sect.
73558 100 CHI=PARU(2)*PYR(0)
73559 CTHE=2D0*PYR(0)-1D0
73567 C2PHI=COS(2D0*(PHI-PARJ(134)))
73568 S2PHI=SIN(2D0*(PHI-PARJ(134)))
73569 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
73570 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
73571 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
73572 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
73573 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
73574 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
73575 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
73576 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
73581 C*********************************************************************
73584 C...Generates Upsilon and toponium decays into three gluons
73585 C...or two gluons and a photon.
73587 SUBROUTINE PYONIA(KFL,ECM)
73589 C...Double precision and integer declarations.
73590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73591 IMPLICIT INTEGER(I-N)
73592 INTEGER PYK,PYCHGE,PYCOMP
73594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73596 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73597 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73599 C...Printout. Check input parameters.
73600 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73601 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73602 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
73603 IF(MSTU(21).GE.1) RETURN
73605 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
73606 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
73607 IF(MSTU(21).GE.1) RETURN
73610 C...Initial e+e- and onium state (optional).
73612 IF(MSTJ(115).GE.2) THEN
73614 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73616 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73620 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
73626 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
73632 C...Choose x1 and x2 according to matrix element.
73637 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
73638 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
73641 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
73642 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
73644 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
73645 MSTU(111)=MSTJ(108)
73646 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73648 PARU(112)=PARJ(121)
73649 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73651 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
73652 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
73655 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
73656 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
73658 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
73659 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
73662 ECMC=SQRT(1D0-X1)*ECM
73663 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
73668 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
73669 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
73670 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
73671 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
73673 IF(ECMC.LT.4D0*PARJ(127)) THEN
73677 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
73683 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
73686 C...Differential cross-sections. Upper limit for cross-section.
73687 IF(MSTJ(106).EQ.1) THEN
73689 HF1=1D0-PARJ(131)*PARJ(132)
73691 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
73692 ST13=SQRT(1D0-CT13**2)
73693 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
73694 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
73696 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
73697 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
73698 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
73700 C...Angular orientation of event.
73701 120 CHI=PARU(2)*PYR(0)
73702 CTHE=2D0*PYR(0)-1D0
73710 C2PHI=COS(2D0*(PHI-PARJ(134)))
73711 S2PHI=SIN(2D0*(PHI-PARJ(134)))
73712 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
73713 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
73714 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
73715 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
73716 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
73717 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
73718 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73719 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73722 C...Generate parton shower. Rearrange along strings and check.
73723 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
73724 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
73726 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73727 IF(MSTJ(105).GE.0) MSTU(28)=0
73730 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73733 C...Generate fragmentation. Information for PYTABU:
73734 IF(MSTJ(105).EQ.1) CALL PYEXEC
73735 MSTU(161)=110*KFLC+3
73741 C*********************************************************************
73744 C...Books a histogram.
73746 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
73748 C...Double precision declaration.
73749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73750 IMPLICIT INTEGER(I-N)
73752 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73754 C...Local character variables.
73755 CHARACTER TITLE*(*), TITFX*60
73757 C...Check that input is sensible. Find initial address in memory.
73758 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73759 &'(PYBOOK:) not allowed histogram number')
73760 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
73761 &'(PYBOOK:) not allowed number of bins')
73762 IF(XL.GE.XU) CALL PYERRM(28,
73763 &'(PYBOOK:) x limits in wrong order')
73765 IHIST(4)=IHIST(4)+28+NX
73766 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
73767 &'(PYBOOK:) out of histogram space')
73770 C...Store histogram size and reset contents.
73774 BIN(IS+4)=(XU-XL)/NX
73777 C...Store title by conversion to integer to double precision.
73780 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
73781 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
73787 C*********************************************************************
73790 C...Fills entry in histogram.
73792 SUBROUTINE PYFILL(ID,X,W)
73794 C...Double precision declaration.
73795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73796 IMPLICIT INTEGER(I-N)
73798 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73801 C...Find initial address in memory. Increase number of entries.
73802 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73803 &'(PYFILL:) not allowed histogram number')
73805 IF(IS.EQ.0) CALL PYERRM(28,
73806 &'(PYFILL:) filling unbooked histogram')
73807 BIN(IS+5)=BIN(IS+5)+1D0
73809 C...Find bin in x, including under/overflow, and fill.
73810 IF(X.LT.BIN(IS+2)) THEN
73811 BIN(IS+6)=BIN(IS+6)+W
73812 ELSEIF(X.GE.BIN(IS+3)) THEN
73813 BIN(IS+8)=BIN(IS+8)+W
73815 BIN(IS+7)=BIN(IS+7)+W
73816 IX=(X-BIN(IS+2))/BIN(IS+4)
73817 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
73818 BIN(IS+9+IX)=BIN(IS+9+IX)+W
73824 C*********************************************************************
73827 C...Multiplies histogram contents by factor.
73829 SUBROUTINE PYFACT(ID,F)
73831 C...Double precision declaration.
73832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73833 IMPLICIT INTEGER(I-N)
73835 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73838 C...Find initial address in memory. Multiply all contents bins.
73839 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73840 &'(PYFACT:) not allowed histogram number')
73842 IF(IS.EQ.0) CALL PYERRM(28,
73843 &'(PYFACT:) scaling unbooked histogram')
73844 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
73851 C*********************************************************************
73854 C...Performs operations between histograms.
73856 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
73858 C...Double precision declaration.
73859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73860 IMPLICIT INTEGER(I-N)
73862 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73864 C...Character variable.
73867 C...Find initial addresses in memory, and histogram size.
73868 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
73869 &'(PYFACT:) not allowed histogram number')
73871 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
73872 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
73873 NX=NINT(BIN(IS3+1))
73874 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
73876 C...Update info on number of histogram entries.
73877 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
73878 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
73879 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
73880 BIN(IS3+5)=BIN(IS1+5)
73883 C...Operations on pair of histograms: addition, subtraction,
73884 C...multiplication, division.
73885 IF(OPER.EQ.'+') THEN
73887 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
73889 ELSEIF(OPER.EQ.'-') THEN
73891 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
73893 ELSEIF(OPER.EQ.'*') THEN
73895 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
73897 ELSEIF(OPER.EQ.'/') THEN
73900 IF(ABS(FA2).LE.1D-20) THEN
73903 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
73907 C...Operations on single histogram: multiplication+addition,
73908 C...square root+addition, logarithm+addition.
73909 ELSEIF(OPER.EQ.'A') THEN
73911 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
73913 ELSEIF(OPER.EQ.'S') THEN
73915 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
73917 ELSEIF(OPER.EQ.'L') THEN
73920 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
73921 & ZMIN=0.8D0*BIN(IS1+IX)
73924 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
73927 C...Operation on two or three histograms: average and
73928 C...standard deviation.
73929 ELSEIF(OPER.EQ.'M') THEN
73931 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
73934 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
73937 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
73940 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
73944 BIN(IS1+IX)=F1*BIN(IS1+IX)
73951 C*********************************************************************
73954 C...Prints and resets all histograms.
73958 C...Double precision declaration.
73959 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73960 IMPLICIT INTEGER(I-N)
73962 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73965 C...Loop over histograms, print and reset used ones.
73966 DO 100 ID=1,IHIST(1)
73968 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
73977 C*********************************************************************
73980 C...Prints a histogram (but does not reset it).
73982 SUBROUTINE PYPLOT(ID)
73984 C...Double precision declaration.
73985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73986 IMPLICIT INTEGER(I-N)
73988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73989 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73990 SAVE /PYDAT1/,/PYBINS/
73991 C...Local arrays and character variables.
73992 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
73993 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
73995 C...Steps in histogram scale. Character sequence.
73996 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
73997 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
73999 C...Find initial address in memory; skip if empty histogram.
74000 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
74003 IF(NINT(BIN(IS+5)).LE.0) THEN
74004 WRITE(MSTU(11),5000) ID
74008 C...Number of histogram lines and x bins.
74012 C...Extract title by conversion from double precision via integer.
74014 IEQ=NINT(BIN(IS+8+NX+IT))
74015 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
74016 & //CHAR(MOD(IEQ,256))
74019 C...Find time; print title.
74021 IF(IDATI(1).GT.0) THEN
74022 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
74024 WRITE(MSTU(11),5200) ID, TITLE
74027 C...Find minimum and maximum bin content.
74030 DO 110 IX=IS+10,IS+8+NX
74031 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
74032 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
74035 C...Determine scale and step size for y axis.
74036 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
74037 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
74038 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
74039 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
74040 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
74041 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
74044 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
74048 C...Convert bin contents to integer form; fractional fill in top row.
74050 CTA=ABS(BIN(IS+8+IX))/DY
74051 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
74052 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
74054 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
74055 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
74057 C...Print histogram row by row.
74058 DO 150 IR=IRMA,IRMI,-1
74059 IF(IR.EQ.0) GOTO 150
74062 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
74063 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
74065 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
74068 C...Print sign and value of bin contents.
74069 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
74072 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
74073 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
74075 WRITE(MSTU(11),5400) OUT
74078 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
74080 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
74083 C...Print sign and value of lower bin edge.
74084 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
74088 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
74089 & OUT(IX:IX)=CHA(11)
74090 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
74092 WRITE(MSTU(11),5600) OUT
74095 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
74097 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
74101 C...Calculate and print statistics.
74106 CTA=ABS(BIN(IS+8+IX))
74107 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
74110 CXXSUM=CXXSUM+CTA*X**2
74112 XMEAN=CXSUM/MAX(CSUM,1D-20)
74113 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
74114 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
74115 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
74117 C...Formats for output.
74118 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
74119 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
74121 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
74122 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
74123 5400 FORMAT(/8X,'Contents',3X,A100)
74124 5500 FORMAT(9X,'*10**',I2,3X,A100)
74125 5600 FORMAT(/8X,'Low edge',3X,A100)
74126 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
74127 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
74128 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
74133 C*********************************************************************
74136 C...Resets bin contents of a histogram.
74138 SUBROUTINE PYNULL(ID)
74140 C...Double precision declaration.
74141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74142 IMPLICIT INTEGER(I-N)
74144 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
74147 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
74150 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
74157 C*********************************************************************
74160 C...Dumps histogram contents on file for reading by other program.
74161 C...Can also read back own dump.
74163 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
74165 C...Double precision declaration.
74166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74167 IMPLICIT INTEGER(I-N)
74169 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
74171 C...Local arrays and character variables.
74172 DIMENSION IHI(*),ISS(100),VAL(5)
74173 CHARACTER TITLE*60,FORMAT*13
74175 C...Dump all histograms that have been booked,
74176 C...including titles and ranges, one after the other.
74177 IF(MDUMP.EQ.1) THEN
74179 C...Loop over histograms and find which are wanted and booked.
74194 C...Write title, histogram size, filling statistics.
74197 IEQ=NINT(BIN(IS+8+NX+IT))
74198 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
74199 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
74201 WRITE(LFN,5100) ID,TITLE
74202 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
74203 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
74207 C...Write histogram contents, in groups of five.
74208 DO 120 IXG=1,(NX+4)/5
74212 VAL(IXV)=BIN(IS+8+IX)
74217 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
74220 C...Go to next histogram; finish.
74221 ELSEIF(NHI.GT.0) THEN
74222 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
74226 C...Read back in histograms dumped MDUMP=1.
74227 ELSEIF(MDUMP.EQ.2) THEN
74229 C...Read histogram number, title and range, and book.
74230 140 READ(LFN,5100,END=170) ID,TITLE
74231 READ(LFN,5200) NX,XL,XU
74232 CALL PYBOOK(ID,TITLE,NX,XL,XU)
74235 C...Read filling statistics.
74236 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
74237 BIN(IS+5)=DBLE(NENTRY)
74239 C...Read histogram contents, in groups of five.
74240 DO 160 IXG=1,(NX+4)/5
74241 READ(LFN,5400) (VAL(IXV),IXV=1,5)
74244 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
74248 C...Go to next histogram; finish.
74252 C...Write histogram contents in column format,
74253 C...convenient e.g. for GNUPLOT input.
74254 ELSEIF(MDUMP.EQ.3) THEN
74256 C...Find addresses to wanted histograms.
74270 IF(IS.NE.0.AND.NSS.LT.100) THEN
74273 ELSEIF(NSS.GE.100) THEN
74274 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
74275 ELSEIF(NHI.GT.0) THEN
74276 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
74280 C...Check that they have common number of x bins. Fix format.
74281 NX=NINT(BIN(ISS(1)+1))
74283 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
74284 CALL PYERRM(8,'(PYDUMP:) different number of bins')
74288 FORMAT='(1P,000E12.4)'
74289 WRITE(FORMAT(5:7),'(I3)') NSS+1
74291 C...Write histogram contents; first column x values.
74293 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
74294 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
74299 C...Formats for output.
74300 5100 FORMAT(I5,5X,A60)
74301 5200 FORMAT(I5,1P,2D12.4)
74302 5300 FORMAT(I12,1P,3D12.4)
74303 5400 FORMAT(1P,5D12.4)
74308 C*********************************************************************
74311 C...Dummy routine, which the user can replace in order to make cuts on
74312 C...the kinematics on the parton level before the matrix elements are
74313 C...evaluated and the event is generated. The cross-section estimates
74314 C...will automatically take these cuts into account, so the given
74315 C...values are for the allowed phase space region only. MCUT=0 means
74316 C...that the event has passed the cuts, MCUT=1 that it has failed.
74318 SUBROUTINE PYKCUT(MCUT)
74320 C...Double precision and integer declarations.
74321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74322 IMPLICIT INTEGER(I-N)
74323 INTEGER PYK,PYCHGE,PYCOMP
74325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74326 COMMON/PYINT1/MINT(400),VINT(400)
74327 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
74328 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
74330 C...Set default value (accepting event) for MCUT.
74333 C...Read out subprocess number.
74337 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
74341 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
74343 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
74345 C...Calculate x_1, x_2, x_F.
74346 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
74347 X1=SQRT(TAU)*EXP(YST)
74348 X2=SQRT(TAU)*EXP(-YST)
74350 X1=SQRT(TAUP)*EXP(YST)
74351 X2=SQRT(TAUP)*EXP(-YST)
74355 C...Calculate shat, that, uhat, p_T^2.
74361 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
74362 RPTS=4D0*VINT(71)**2/SHAT
74363 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
74366 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
74367 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
74368 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
74369 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
74371 C...Decisions by user to be put here.
74373 C...Stop program if this routine is ever called.
74374 C...You should not copy these lines to your own routine.
74375 WRITE(MSTU(11),5000)
74376 IF(PYR(0).LT.10D0) STOP
74378 C...Format for error printout.
74379 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
74380 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
74381 &1X,'Execution stopped!')
74386 C*********************************************************************
74389 C...Dummy routine, which the user can replace in order to multiply the
74390 C...standard PYTHIA differential cross-section by a process- and
74391 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
74392 C...to generation of weighted events, with weight 1/WTXS, while for
74393 C...MSTP(142)=2 it corresponds to a modification of the underlying
74396 SUBROUTINE PYEVWT(WTXS)
74398 C...Double precision and integer declarations.
74399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74400 IMPLICIT INTEGER(I-N)
74401 INTEGER PYK,PYCHGE,PYCOMP
74403 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74404 COMMON/PYINT1/MINT(400),VINT(400)
74405 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
74406 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
74408 C...Set default weight for WTXS.
74411 C...Read out subprocess number.
74415 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
74419 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
74421 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
74423 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
74432 C...Modifications by user to be put here.
74434 C...Stop program if this routine is ever called.
74435 C...You should not copy these lines to your own routine.
74436 WRITE(MSTU(11),5000)
74437 IF(PYR(0).LT.10D0) STOP
74439 C...Format for error printout.
74440 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
74441 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
74442 &1X,'Execution stopped!')
74447 C*********************************************************************
74450 C...Dummy routine, to be replaced by a user implementing external
74451 C...processes. Is supposed to fill the HEPRUP commonblock with info
74452 C...on incoming beams and allowed processes.
74454 C...New example: handles a standard Les Houches Events File.
74458 C...Double precision and integer declarations.
74459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74460 IMPLICIT INTEGER(I-N)
74462 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
74463 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74466 C...User process initialization commonblock.
74468 PARAMETER (MAXPUP=100)
74469 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
74470 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
74471 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
74472 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
74476 C...Lines to read in assumed never longer than 200 characters.
74477 PARAMETER (MAXLEN=200)
74478 CHARACTER*(MAXLEN) STRING
74480 C...Format for reading lines.
74483 WRITE(STRFMT(3:5),'(I3)') MAXLEN
74485 C...Loop until finds line beginning with "<init>" or "<init ".
74486 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
74489 C...Allow indentation.
74490 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
74491 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
74492 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
74494 C...Read first line of initialization info.
74495 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
74496 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
74498 C...Read NPRUP subsequent lines with information on each process.
74500 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
74501 & XMAXUP(IPR),LPRUP(IPR)
74505 C...Error exit: give up if initalization does not work.
74506 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
74507 WRITE(*,*) ' Event generation will be stopped.'
74513 C...Old example: handles a simple Pythia 6.4 initialization file.
74515 c SUBROUTINE UPINIT
74517 C...Double precision and integer declarations.
74518 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74519 c IMPLICIT INTEGER(I-N)
74522 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74523 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74524 c SAVE /PYDAT1/,/PYPARS/
74526 C...User process initialization commonblock.
74528 c PARAMETER (MAXPUP=100)
74529 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
74530 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
74531 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
74532 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
74536 C...Read info from file.
74537 c IF(MSTP(161).GT.0) THEN
74538 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
74539 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
74540 c DO 100 IPR=1,NPRUP
74541 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
74542 c & XMAXUP(IPR),LPRUP(IPR)
74545 C...Error or prematurely reached end of file.
74546 c 110 WRITE(MSTU(11),5000)
74549 C...Else not implemented.
74551 c WRITE(MSTU(11),5100)
74555 C...Format for error printout.
74556 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
74557 c &1X,'Execution stopped!')
74558 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
74559 c &1X,'Dummy routine in PYTHIA file called instead.'/
74560 c &1X,'Execution stopped!')
74565 C*********************************************************************
74568 C...Dummy routine, to be replaced by a user implementing external
74569 C...processes. Depending on cross section model chosen, it either has
74570 C...to generate a process of the type IDPRUP requested, or pick a type
74571 C...itself and generate this event. The event is to be stored in the
74572 C...HEPEUP commonblock, including (often) an event weight.
74574 C...New example: handles a standard Les Houches Events File.
74578 C...Double precision and integer declarations.
74579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74580 IMPLICIT INTEGER(I-N)
74582 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
74583 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74586 C...User process event common block.
74588 PARAMETER (MAXNUP=500)
74589 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74590 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74591 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74592 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74593 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74596 C...Lines to read in assumed never longer than 200 characters.
74597 PARAMETER (MAXLEN=200)
74598 CHARACTER*(MAXLEN) STRING
74600 C...Format for reading lines.
74603 WRITE(STRFMT(3:5),'(I3)') MAXLEN
74605 C...Loop until finds line beginning with "<event>" or "<event ".
74606 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
74609 C...Allow indentation.
74610 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
74611 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
74612 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
74614 C...Read first line of event info.
74615 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
74618 C...Read NUP subsequent lines with information on each particle.
74620 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
74621 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
74622 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
74626 C...Error exit, typically when no more events.
74627 130 WRITE(*,*) ' Failed to read LHEF event information.'
74628 WRITE(*,*) ' Will assume end of file has been reached.'
74635 C...Old example: handles a simple Pythia 6.4 event file.
74637 c SUBROUTINE UPEVNT
74639 C...Double precision and integer declarations.
74640 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74641 c IMPLICIT INTEGER(I-N)
74644 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74645 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74646 c SAVE /PYDAT1/,/PYPARS/
74648 C...User process event common block.
74650 c PARAMETER (MAXNUP=500)
74651 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74652 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74653 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74654 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74655 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74658 C...Read info from file.
74659 c IF(MSTP(162).GT.0) THEN
74660 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
74663 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
74664 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
74665 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
74668 C...Special when reached end of file or other error.
74671 C...Else not implemented.
74673 c WRITE(MSTU(11),5000)
74677 C...Format for error printout.
74678 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
74679 c &1X,'Dummy routine in PYTHIA file called instead.'/
74680 c &1X,'Execution stopped!')
74685 C*********************************************************************
74688 C...Dummy routine, to be replaced by user, to veto event generation
74689 C...on the parton level, after parton showers but before multiple
74690 C...interactions, beam remnants and hadronization is added.
74691 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
74692 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
74693 C...be undecayed at this stage; if decayed their decay products will
74694 C...have been allowed to shower.
74696 C...All partons at the end of the shower phase are stored in the
74697 C...HEPEVT commonblock. The interesting information is
74698 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
74699 C...IDHEP(I) = the particle ID code according to PDG conventions,
74700 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
74701 C...All ISTHEP entries are 1, while the rest is zeroed.
74703 C...The user decision is to be conveyed by the IVETO value.
74704 C...IVETO = 0 : retain current event and generate in full;
74705 C... = 1 : abort generation of current event and move to next.
74707 SUBROUTINE UPVETO(IVETO)
74709 C...HEPEVT commonblock.
74710 PARAMETER (NMXHEP=4000)
74711 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
74712 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
74713 DOUBLE PRECISION PHEP,VHEP
74716 C...Next few lines allow you to see what info PYVETO extracted from
74717 C...the full event record for the first two events.
74718 C...Delete if you don't want it.
74721 IF(NLIST.LE.2) THEN
74722 WRITE(*,*) ' Full event record at time of UPVETO call:'
74724 WRITE(*,*) ' Part of event record made available to UPVETO:'
74729 C...Make decision here.
74735 C*********************************************************************
74738 C...Dummy routine, to be removed when PDFLIB is to be linked.
74740 SUBROUTINE PDFSET(PARM,VALUE)
74742 C...Double precision and integer declarations.
74743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74744 IMPLICIT INTEGER(I-N)
74745 INTEGER PYK,PYCHGE,PYCOMP
74747 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74749 C...Local arrays and character variables.
74750 CHARACTER*20 PARM(20)
74751 DOUBLE PRECISION VALUE(20)
74753 C...Stop program if this routine is ever called.
74754 WRITE(MSTU(11),5000)
74755 IF(PYR(0).LT.10D0) STOP
74759 C...Format for error printout.
74760 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74761 &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/
74762 &1X,'Execution stopped!')
74767 C*********************************************************************
74770 C...Dummy routine, to be removed when PDFLIB is to be linked.
74772 SUBROUTINE STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
74774 C...Double precision and integer declarations.
74775 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74776 IMPLICIT INTEGER(I-N)
74777 INTEGER PYK,PYCHGE,PYCOMP
74779 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74781 C...Local variables
74782 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
74784 C...Stop program if this routine is ever called.
74785 WRITE(MSTU(11),5000)
74786 IF(PYR(0).LT.10D0) STOP
74797 C...Format for error printout.
74798 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74799 &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/
74800 &1X,'Execution stopped!')
74805 C*********************************************************************
74808 C...Dummy routine, to be removed when PDFLIB is to be linked.
74810 SUBROUTINE STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
74813 C...Double precision and integer declarations.
74814 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74815 IMPLICIT INTEGER(I-N)
74816 INTEGER PYK,PYCHGE,PYCOMP
74818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74820 C...Local variables
74821 DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
74824 C...Stop program if this routine is ever called.
74825 WRITE(MSTU(11),5000)
74826 IF(PYR(0).LT.10D0) STOP
74837 C...Format for error printout.
74838 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74839 &1X,'Dummy routine STRUCTP in PYTHIA file called instead.'/
74840 &1X,'Execution stopped!')
74845 C*********************************************************************
74848 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
74850 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
74851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74852 IMPLICIT INTEGER(I-N)
74853 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
74856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74859 C...Stop program if this routine is ever called.
74860 WRITE(MSTU(11),5000)
74861 IF(PYR(0).LT.10D0) STOP
74863 C...Format for error printout.
74864 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74865 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
74866 &1X,'Execution stopped!')
74871 C*********************************************************************
74874 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
74877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74878 IMPLICIT INTEGER(I-N)
74879 CHARACTER*40 VISAJE
74882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74885 C...Assign default value.
74888 C...Stop program if this routine is ever called.
74889 WRITE(MSTU(11),5000)
74890 IF(PYR(0).LT.10D0) STOP
74892 C...Format for error printout.
74893 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74894 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
74895 &1X,'Execution stopped!')
74900 C*********************************************************************
74903 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
74905 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
74906 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
74907 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
74909 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74910 IMPLICIT INTEGER(I-N)
74911 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
74912 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
74913 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
74915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74918 C...Stop program if this routine is ever called.
74919 WRITE(MSTU(11),5000)
74920 IF(PYR(0).LT.10D0) STOP
74922 C...Format for error printout.
74923 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74924 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
74925 &1X,'Execution stopped!')
74929 C*********************************************************************
74932 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74934 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
74935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74936 IMPLICIT INTEGER(I-N)
74937 Cmssmpart = 4 # full MSSM [recommended]
74938 Cfieldren = 0 # MSbar field ren. [strongly recommended]
74939 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
74940 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
74941 Cp2approx = 0 # no approximation [recommended]
74942 Clooplevel= 2 # include 2-loop corrections
74943 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
74944 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
74947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74950 C...Stop program if this routine is ever called.
74951 WRITE(MSTU(11),5000)
74952 IF(PYR(0).LT.10D0) STOP
74954 C...Format for error printout.
74955 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
74956 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
74957 &1X,'Execution stopped!')
74961 C*********************************************************************
74964 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74966 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
74967 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
74968 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
74969 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
74970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74971 IMPLICIT INTEGER(I-N)
74973 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
74974 DOUBLE COMPLEX DMU,
74975 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
74979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74982 C...Stop program if this routine is ever called.
74983 WRITE(MSTU(11),5000)
74984 IF(PYR(0).LT.10D0) STOP
74986 C...Format for error printout.
74987 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
74988 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
74989 &1X,'Execution stopped!')
74993 C*********************************************************************
74996 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74998 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
74999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75000 IMPLICIT INTEGER(I-N)
75002 C...FeynHiggs variables
75003 DOUBLE PRECISION RMHIGG(4)
75004 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
75005 DOUBLE COMPLEX DMU,
75006 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
75010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75013 C...Stop program if this routine is ever called.
75014 WRITE(MSTU(11),5000)
75015 IF(PYR(0).LT.10D0) STOP
75017 C...Format for error printout.
75018 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
75019 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
75020 &1X,'Execution stopped!')
75024 C*********************************************************************
75027 C...Dummy routine, to be replaced by user, to handle the decay of a
75028 C...polarized tau lepton.
75030 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
75031 C...IORIG is the position where the mother of the tau is stored;
75032 C... is 0 when the mother is not stored.
75033 C...KFORIG is the flavour of the mother of the tau;
75034 C... is 0 when the mother is not known.
75035 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
75036 C... e.g. in B hadron semileptonic decays the W propagator
75037 C... is not explicitly stored but the W code is still unambiguous.
75039 C...NDECAY is the number of decay products in the current tau decay.
75040 C...These decay products should be added to the /PYJETS/ common block,
75041 C...in positions N+1 through N+NDECAY. For each product I you must
75042 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
75043 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
75045 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
75047 C...Double precision and integer declarations.
75048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75049 IMPLICIT INTEGER(I-N)
75050 INTEGER PYK,PYCHGE,PYCOMP
75052 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75054 SAVE /PYJETS/,/PYDAT1/
75056 C...Stop program if this routine is ever called.
75057 C...You should not copy these lines to your own routine.
75058 NDECAY=ITAU+IORIG+KFORIG
75059 WRITE(MSTU(11),5000)
75060 IF(PYR(0).LT.10D0) STOP
75062 C...Format for error printout.
75063 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
75064 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75065 &1X,'Execution stopped!')
75070 C*********************************************************************
75073 C...Finds current date and time.
75074 C...Since this task is not standardized in Fortran 77, the routine
75075 C...is dummy, to be replaced by the user. Examples are given for
75076 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
75077 C...you do not have access to suitable routines.
75079 SUBROUTINE PYTIME(IDATI)
75081 C...Double precision and integer declarations.
75082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75083 IMPLICIT INTEGER(I-N)
75084 INTEGER PYK,PYCHGE,PYCOMP
75087 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
75089 C...Example 0: if you do not have suitable routines.
75094 C...Example 1: Fortran 90 routine.
75095 C CALL DATE_AND_TIME(VALUES=IVAL)
75103 C...Example 2: DEC Fortran 77. AIX.
75104 C CALL IDATE(IMON,IDAY,IYEAR)
75108 C CALL ITIME(IHOUR,IMIN,ISEC)
75113 C...Example 3: DEC Fortran, IRIX, IRIX64.
75114 C CALL IDATE(IMON,IDAY,IYEAR)
75122 C READ(ATIME(1:2),'(I2)') IHOUR
75123 C READ(ATIME(4:5),'(I2)') IMIN
75124 C READ(ATIME(7:8),'(I2)') ISEC
75129 C...Example 4: GNU LINUX libU77, SunOS.
75130 C CALL IDATE(IDTEMP)
75131 C IDATI(1)=IDTEMP(3)
75132 C IDATI(2)=IDTEMP(2)
75133 C IDATI(3)=IDTEMP(1)
75134 C CALL ITIME(IDTEMP)
75135 C IDATI(4)=IDTEMP(1)
75136 C IDATI(5)=IDTEMP(2)
75137 C IDATI(6)=IDTEMP(3)
75139 C...Common code to ensure right century.
75140 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob