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 **
34 C* CERN/PH, CH-1211 Geneva, Switzerland **
35 C* phone +41 - 22 - 767 24 59 **
36 C* E-mail skands@fnal.gov **
38 C* Several parts are written by Hans-Uno Bengtsson **
39 C* PYSHOW is written together with Mats Bengtsson **
40 C* PYMAEL is written by Emanuel Norrbin **
41 C* advanced popcorn baryon production written by Patrik Eden **
42 C* code for virtual photons mainly written by Christer Friberg **
43 C* code for low-mass strings mainly written by Emanuel Norrbin **
44 C* Bose-Einstein code mainly written by Leif Lonnblad **
45 C* CTEQ parton distributions are by the CTEQ collaboration **
46 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
47 C* SaS photon parton distributions together with Gerhard Schuler **
48 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
49 C* MSSM Higgs mass calculation code by M. Carena, **
50 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
51 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
52 C* NRQCD/colour octet production of onium by S. Wolf **
54 C* The latest program version and documentation is found on WWW **
55 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
57 C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
59 C*********************************************************************
60 C*********************************************************************
62 C List of subprograms in order of appearance, with main purpose *
63 C (S = subroutine, F = function, B = block data) *
65 C B PYDATA to contain all default values *
66 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
67 C S PYTEST to test the proper functioning of the package *
68 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
70 C S PYINIT to administer the initialization procedure *
71 C S PYEVNT to administer the generation of an event *
72 C S PYEVNW ditto, for new multiple interactions scenario *
73 C S PYSTAT to print cross-section and other information *
74 C S PYUPEV to administer the generation of an LHA hard process *
75 C S PYUPIN to provide initialization needed for LHA input *
76 C S PYLHEF to produce a Les Houches Event File from run *
77 C S PYINRE to initialize treatment of resonances *
78 C S PYINBM to read in beam, target and frame choices *
79 C S PYINKI to initialize kinematics of incoming particles *
80 C S PYINPR to set up the selection of included processes *
81 C S PYXTOT to give total, elastic and diffractive cross-sect. *
82 C S PYMAXI to find differential cross-section maxima *
83 C S PYPILE to select multiplicity of pileup events *
84 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
85 C S PYGAGA to handle lepton -> lepton + gamma branchings *
86 C S PYRAND to select subprocess and kinematics for event *
87 C S PYSCAT to set up kinematics and colour flow of event *
88 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
89 C S PYSSPA to simulate initial state spacelike showers *
90 C S PYPTIS to do pT-ordered initial state spacelike showers *
91 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
92 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
93 C S PYPTMI to do pT-ordered multiple interactions *
94 C F PYFCMP to give companion quark x*f distribution *
95 C F PYPCMP to calculate momentum integral for companion quarks *
96 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
97 C S PYADSH to administrate sequential final-state showers *
98 C S PYVETO to allow the generation of an event to be aborted *
99 C S PYRESD to perform resonance decays *
100 C S PYMULT to generate multiple interactions - old scheme *
101 C S PYREMN to add on target remnants - old scheme *
102 C S PYMIGN to generate multiple interactions - new scheme *
103 C S PYMIHK to connect colours in mult. int. - new scheme *
104 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
105 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
106 C S PYMIRM to add on target remnants in mult. int.- new scheme *
107 C S PYFSCR to perform final state colour reconnections - -"- *
108 C S PYDIFF to set up kinematics for diffractive events *
109 C S PYDISG to set up kinematics, remnant and showers for DIS *
110 C S PYDOCU to compute cross-sections and handle documentation *
111 C S PYFRAM to perform boosts between different frames *
112 C S PYWIDT to calculate full and partial widths of resonances *
113 C S PYOFSH to calculate partial width into off-shell channels *
114 C S PYRECO to handle colour reconnection in W+W- events *
115 C S PYKLIM to calculate borders of allowed kinematical region *
116 C S PYKMAP to construct value of kinematical variable *
117 C S PYSIGH to calculate differential cross-sections *
118 C S PYSGQC auxiliary to PYSIGH for QCD processes *
119 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
120 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
121 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
122 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
123 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
124 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
125 C S PYPDFU to evaluate parton distributions *
126 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
127 C S PYPDEL to evaluate electron parton distributions *
128 C S PYPDGA to evaluate photon parton distributions (generic) *
129 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
130 C S PYGVMD to evaluate VMD part of photon parton distributions *
131 C S PYGANO to evaluate anomalous part of photon PDFs *
132 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
133 C S PYGDIR to evaluate direct contribution to photon PDFs *
134 C S PYPDPI to evaluate pion parton distributions *
135 C S PYPDPR to evaluate proton parton distributions *
136 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
137 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
138 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
139 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
140 C F PYGRVV auxiliary to the PYGRV* routines *
141 C F PYGRVW auxiliary to the PYGRV* routines *
142 C F PYGRVS auxiliary to the PYGRV* routines *
143 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
144 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
145 C S PYPDPO to evaluate old proton parton distributions *
146 C F PYHFTH to evaluate threshold factor for heavy flavour *
147 C S PYSPLI to find flavours left in hadron when one removed *
148 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
149 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
150 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
151 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
152 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
153 C S PYSTBH to evaluate matrix element for t + b + H processes *
154 C S PYTBHB auxiliary to PYSTBH *
155 C S PYTBHG auxiliary to PYSTBH *
156 C S PYTBHQ auxiliary to PYSTBH *
157 C F PYTBHS auxiliary to PYSTBH *
159 C S PYMSIN to initialize the supersymmetry simulation *
160 C S PYSLHA to interface to SUSY spectrum and decay calculators *
161 C S PYAPPS to determine MSSM parameters from SUGRA input *
162 C S PYSUGI to determine MSSM parameters using ISASUSY *
163 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
164 C F PYRNMQ to determine running squark masses *
165 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
166 C S PYINOM to calculate neutralino/chargino mass eigenstates *
167 C F PYRNM3 to determine running M3, gluino mass *
168 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
169 C S PYHGGM to determine Higgs mass spectrum *
170 C S PYSUBH to determine Higgs masses in the MSSM *
171 C S PYPOLE to determine Higgs masses in the MSSM *
172 C S PYRGHM auxiliary to PYPOLE *
173 C S PYGFXX auxiliary to PYRGHM *
174 C F PYFINT auxiliary to PYPOLE *
175 C F PYFISB auxiliary to PYFINT *
176 C S PYSFDC to calculate sfermion decay partial widths *
177 C S PYGLUI to calculate gluino decay partial widths *
178 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
179 C S PYTBBC to calculate 3-body decay of gluino to chargino *
180 C S PYNJDC to calculate neutralino decay partial widths *
181 C S PYCJDC to calculate chargino decay partial widths *
182 C F PYXXZ6 auxiliary for ino 3-body decays *
183 C F PYXXGA auxiliary for ino -> ino + gamma decay *
184 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
185 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
186 C S PYHEXT to calculate non-SM Higgs decay partial widths *
187 C F PYH2XX auxiliary for H -> ino + ino decay *
188 C F PYGAUS to perform Gaussian integration *
189 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
190 C F PYSIMP to perform Simpson integration *
191 C F PYLAMF to evaluate the lambda kinematics function *
192 C S PYTBDY to perform 3-body decay of gauginos *
193 C S PYTECM to calculate techni_rho/omega masses *
194 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195 C S PYCMQR auxiliary to PYEICG *
196 C S PYCMQ2 auxiliary to PYEICG *
197 C S PYCDIV auxiliary to PYCMQR *
198 C S PYCSRT auxiliary to PYCMQR *
199 C S PYTHAG auxiliary to PYCMQR *
200 C S PYCBAL auxiliary to PYEICG *
201 C S PYCBA2 auxiliary to PYEICG *
202 C S PYCRTH auxiliary to PYEICG *
203 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205 C S PYWIDX to calculate decay widths from within PYWIDT *
206 C S PYRVSF to calculate R-violating sfermion decay widths *
207 C S PYRVNE to calculate R-violating neutralino decay widths *
208 C S PYRVCH to calculate R-violating chargino decay widths *
209 C S PYRVGL to calculate R-violating gluino decay widths *
210 C F PYRVSB auxiliary to PYRVSF *
211 C S PYRVGW to calculate R-Violating 3-body widths *
212 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
222 C S PY1ENT to fill one entry (= parton or particle) *
223 C S PY2ENT to fill two entries *
224 C S PY3ENT to fill three entries *
225 C S PY4ENT to fill four entries *
226 C S PY2FRM to interface to generic two-fermion generator *
227 C S PY4FRM to interface to generic four-fermion generator *
228 C S PY6FRM to interface to generic six-fermion generator *
229 C S PY4JET to generate a shower from a given 4-parton config *
230 C S PY4JTW to evaluate the weight od a shower history for above *
231 C S PY4JTS to set up the parton configuration for above *
232 C S PYJOIN to connect entries with colour flow information *
233 C S PYGIVE to fill (or query) commonblock variables *
234 C S PYONOF to allow easy control of particle decay modes *
235 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236 C S PYEXEC to administrate fragmentation and decay chain *
237 C S PYPREP to rearrange showered partons along strings *
238 C S PYSTRF to do string fragmentation of jet system *
239 C S PYJURF to find boost to string junction rest frame *
240 C S PYINDF to do independent fragmentation of one or many jets *
241 C S PYDECY to do the decay of a particle *
242 C S PYDCYK to select parton and hadron flavours in decays *
243 C S PYKFDI to select parton and hadron flavours in fragm *
244 C S PYNMES to select number of popcorn mesons *
245 C S PYKFIN to calculate falvour prod. ratios from input params. *
246 C S PYPTDI to select transverse momenta in fragm *
247 C S PYZDIS to select longitudinal scaling variable in fragm *
248 C S PYSHOW to do m-ordered timelike parton shower evolution *
249 C S PYPTFS to do pT-ordered timelike parton shower evolution *
250 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251 C S PYBOEI to include Bose-Einstein effects (crudely) *
252 C S PYBESQ auxiliary to PYBOEI *
253 C F PYMASS to give the mass of a particle or parton *
254 C F PYMRUN to give the running MSbar mass of a quark *
255 C S PYNAME to give the name of a particle or parton *
256 C F PYCHGE to give three times the electric charge *
257 C F PYCOMP to compress standard KF flavour code to internal KC *
258 C S PYERRM to write error messages and abort faulty run *
259 C F PYALEM to give the alpha_electromagnetic value *
260 C F PYALPS to give the alpha_strong value *
261 C F PYANGL to give the angle from known x and y components *
262 C F PYR to provide a random number generator *
263 C S PYRGET to save the state of the random number generator *
264 C S PYRSET to set the state of the random number generator *
265 C S PYROBO to rotate and/or boost an event *
266 C S PYEDIT to remove unwanted entries from record *
267 C S PYLIST to list event record or particle data *
268 C S PYLOGO to write a logo *
269 C S PYUPDA to update particle data *
270 C F PYK to provide integer-valued event information *
271 C F PYP to provide real-valued event information *
272 C S PYSPHE to perform sphericity analysis *
273 C S PYTHRU to perform thrust analysis *
274 C S PYCLUS to perform three-dimensional cluster analysis *
275 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276 C S PYJMAS to give high and low jet mass of event *
277 C S PYFOWO to give Fox-Wolfram moments *
278 C S PYTABU to analyze events, with tabular output *
280 C S PYEEVT to administrate the generation of an e+e- event *
281 C S PYXTEE to give the total cross-section at given CM energy *
282 C S PYRADK to generate initial state photon radiation *
283 C S PYXKFL to select flavour of primary qqbar pair *
284 C S PYXJET to select (matrix element) jet multiplicity *
285 C S PYX3JT to select kinematics of three-jet event *
286 C S PYX4JT to select kinematics of four-jet event *
287 C S PYXDIF to select angular orientation of event *
288 C S PYONIA to perform generation of onium decay to gluons *
290 C S PYBOOK to book a histogram *
291 C S PYFILL to fill an entry in a histogram *
292 C S PYFACT to multiply histogram contents by a factor *
293 C S PYOPER to perform operations between histograms *
294 C S PYHIST to print and reset all histograms *
295 C S PYPLOT to print a single histogram *
296 C S PYNULL to reset contents of a single histogram *
297 C S PYDUMP to dump histogram contents onto a file *
299 C S PYSTOP routine to handle Fortran STOP condition *
301 C S PYKCUT dummy routine for user kinematical cuts *
302 C S PYEVWT dummy routine for weighting events *
303 C S UPINIT dummy routine to initialize user processes *
304 C S UPEVNT dummy routine to generate a user process event *
305 C S UPVETO dummy routine to abort event at parton level *
306 C S PDFSET dummy routine to be removed when using PDFLIB *
307 C S STRUCTM dummy routine to be removed when using PDFLIB *
308 C S STRUCTP dummy routine to be removed when using PDFLIB *
309 C S SUGRA dummy routine to be removed when linking with ISAJET *
310 C F VISAJE dummy functn. to be removed when linking with ISAJET *
311 C S SSMSSM dummy routine to be removed when linking with ISAJET *
312 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313 C S FHSETPARA dummy routine -"- FEYNHIGGS *
314 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315 C S PYTAUD dummy routine for interface to tau decay libraries *
316 C S PYTIME dummy routine for giving date and time *
318 C*********************************************************************
321 C...Default values for switches and parameters,
322 C...and particle, decay and process data.
326 C...Double precision and integer declarations.
327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
328 IMPLICIT INTEGER(I-N)
329 INTEGER PYK,PYCHGE,PYCOMP
331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
333 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
334 COMMON/PYDAT4/CHAF(500,2)
336 COMMON/PYDATR/MRPY(6),RRPY(100)
337 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
339 COMMON/PYINT1/MINT(400),VINT(400)
340 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
341 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
342 COMMON/PYINT4/MWID(500),WIDS(500,5)
343 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
344 COMMON/PYINT6/PROC(0:500)
346 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
347 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
348 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
349 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
350 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
351 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
352 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
353 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
354 & AU(3,3),AD(3,3),AE(3,3)
355 COMMON/PYLH3C/CPRO(2),CVER(2)
356 CHARACTER CPRO*12,CVER*12
357 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
358 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
359 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
360 &/PYBINS/,/PYLH3P/,/PYLH3C/
362 C...PYDAT1, containing status codes and most parameters.
364 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
365 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
366 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
367 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
368 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
369 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
370 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
372 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
375 DATA (PARU(I),I=1,100)/
376 & 3.141592653589793D0, 6.283185307179586D0,
377 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
378 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
380 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
381 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
382 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
383 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
385 DATA (PARU(I),I=101,200)/
386 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
387 & 0D0, 0D0, 0D0, 0D0, 0D0,
388 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
389 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
390 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
391 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
392 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
393 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
395 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
396 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
397 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
399 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
400 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
401 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
402 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
403 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
404 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
406 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
407 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
410 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
411 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
412 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
413 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
414 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
415 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
416 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
417 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
418 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
419 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
420 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
421 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
422 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
423 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
424 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
425 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
426 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
430 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
431 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
432 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
433 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
436 C...PYDAT2, with particle data and flavour treatment parameters.
437 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
438 &-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,
439 &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,
440 &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,
441 &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,
442 &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,
443 &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,
444 &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,
445 &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,
447 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
448 &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,
449 &-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,
450 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
451 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
452 &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,
453 &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,
454 &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,7*0,1,131*0/
455 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
456 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
457 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
458 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
459 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
460 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
461 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
462 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
463 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
464 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
465 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
466 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
467 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
468 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
469 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
470 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
471 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
472 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
473 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
474 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
475 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
476 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
477 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
478 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
479 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
480 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
481 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
482 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
483 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
484 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
485 &3000115,3000215,131*0/
486 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
487 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
488 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
489 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
490 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
491 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
492 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
493 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
494 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
495 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
496 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
497 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
498 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
499 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
500 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
501 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
502 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
503 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
504 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
505 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
506 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
507 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
508 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
509 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
510 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
511 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
512 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
513 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
514 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
515 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
516 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
517 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
518 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
519 &3*9.5D0,2*250D0,131*0D0/
520 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
521 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
522 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
523 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
524 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
525 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
526 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
527 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
528 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
529 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
530 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
531 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
532 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
533 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
534 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
535 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
536 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
537 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
538 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
539 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
540 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
541 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
542 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
543 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
544 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
545 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
546 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
547 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
548 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
549 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
550 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
551 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
552 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
553 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
554 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
555 &8.80013D0,13*0D0,2.54987D0,2.84456D0,131*0D0/
556 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
557 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
558 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
559 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
560 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
561 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
562 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
563 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
566 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
567 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
568 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
569 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
570 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
571 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
572 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
573 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
574 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
575 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
576 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
577 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
578 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
580 4 0.2D0, 0.5D0, 8*0D0,
582 DATA ((VCKM(I,J),J=1,4),I=1,4)/
583 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
584 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
585 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
586 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
588 C...PYDAT3, with particle decay parameters and data.
589 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
590 &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,
591 &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,
592 &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,8*1,131*0/
593 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
594 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
595 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
596 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
597 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
598 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
599 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
600 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
601 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
602 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
603 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
604 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
605 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
606 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
607 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
608 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
609 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
610 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
611 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
612 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
613 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
614 &4214,4215,4216,4296,4322,131*0/
615 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
616 &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,
617 &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,
618 &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,
619 &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,
620 &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,
621 &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,
622 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
623 &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
624 &3*22,15,12,2*7,7*0,6*1,26,30,131*0/
625 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
626 &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,
627 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
628 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
629 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
630 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
631 &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
632 &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
634 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
635 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
636 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
637 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
638 &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,
639 &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,
640 &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,
641 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
642 &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,
643 &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,
644 &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,
645 &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,
646 &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,
647 &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
648 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
650 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
651 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
652 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
653 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
654 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
655 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
656 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
657 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
658 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
659 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
660 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
661 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
662 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
663 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
664 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
665 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
666 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
667 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
668 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
669 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
670 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
671 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
672 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
673 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
674 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
675 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
676 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
677 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
678 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
679 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
680 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
681 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
682 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
683 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
684 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
685 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
686 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
687 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
688 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
689 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
690 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
691 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
692 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
693 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
694 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
695 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
696 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
697 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
698 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
699 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
700 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
701 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
702 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
703 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
704 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
705 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
706 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
707 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
708 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
709 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
710 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
711 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
712 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
713 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
714 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
715 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
716 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
717 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
718 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
719 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
720 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
721 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
722 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
723 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
724 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
725 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
726 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
727 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
728 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
729 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
730 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
731 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
732 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
733 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
734 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
735 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
736 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
737 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
738 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
739 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
740 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
741 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
742 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
743 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
744 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
745 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
746 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
747 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
748 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
749 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
750 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
751 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
752 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
753 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
754 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
755 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
756 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
757 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
758 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
759 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
760 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
761 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
762 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
763 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
764 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
765 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
766 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
767 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
768 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
769 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
770 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
771 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
772 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
773 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
774 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
775 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
776 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
777 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
778 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
779 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
780 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
781 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
782 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
783 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
784 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
785 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
786 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
787 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
788 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
789 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
790 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
791 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
792 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
793 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
794 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
795 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
796 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
797 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
798 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
799 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
800 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
801 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
802 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
803 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
804 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
805 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
806 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
807 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
808 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
809 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
810 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
811 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
812 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
813 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
814 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
815 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
816 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
817 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
818 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
819 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
820 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
821 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
822 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
823 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
824 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
825 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
826 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
827 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
828 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
829 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
830 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
831 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
832 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
833 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
834 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
835 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
836 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
837 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
838 &2*0.011947D0,0.011946D0,0D0,3649*0D0/
839 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
840 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
841 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
842 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
843 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
844 &-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,
845 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
846 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
847 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
848 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
849 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
850 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
851 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
852 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
853 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
854 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
855 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
856 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
857 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
858 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
859 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
860 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
861 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
862 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
863 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
864 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
865 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
866 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
867 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
868 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
869 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
870 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
871 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
872 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
873 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
874 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
875 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
876 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
877 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
878 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
879 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
880 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
881 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
882 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
883 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
884 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
885 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
886 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
887 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
888 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
889 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
890 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
891 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
892 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
893 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
894 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
895 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
896 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
897 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
898 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
899 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
900 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
901 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
902 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
903 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
904 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
905 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
906 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
907 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
908 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
909 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
910 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
911 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
912 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
913 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
914 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
915 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
916 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
917 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
918 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
919 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
920 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
921 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
922 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
923 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
924 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
925 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
926 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
927 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
928 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
929 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
930 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
931 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
932 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
933 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
934 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
935 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
936 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
937 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
938 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
939 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
940 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
941 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
942 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
943 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
944 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
945 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
946 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
947 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
948 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
949 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
950 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
951 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
952 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
953 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
954 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
955 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
956 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
957 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
958 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
959 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
960 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
961 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
962 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
963 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
964 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
965 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
966 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
967 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
968 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
969 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
970 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
971 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
972 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
973 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
974 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
975 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
976 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
977 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
978 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
979 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
980 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
981 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
982 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
983 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
984 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
985 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
986 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
987 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
988 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
989 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
990 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
991 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
992 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
993 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
994 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
995 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
996 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
997 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
998 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
999 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1000 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1001 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1002 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1003 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1004 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1005 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1006 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1007 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1008 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1009 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1010 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1011 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1012 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1013 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1014 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1015 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1016 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1017 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1018 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1019 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1020 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1021 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1022 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1023 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1024 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1025 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1026 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1027 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1028 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1029 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1030 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1031 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1032 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1033 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1034 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1035 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1036 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1037 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1038 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1039 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1040 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1041 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1042 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1043 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1044 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1045 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1046 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1047 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1048 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1049 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1050 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1051 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1052 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1053 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1054 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1055 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1056 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1057 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1058 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1059 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1060 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1061 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1062 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1063 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1064 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1065 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1066 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1067 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1068 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1069 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1070 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1071 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1072 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1073 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1074 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1075 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1076 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1077 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1078 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1079 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1080 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1081 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1082 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1083 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1084 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1085 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1086 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1087 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1088 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1089 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1090 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1091 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1092 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1093 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1094 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1095 &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,
1096 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1097 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1098 &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
1099 DATA (KFDP(I,1),I=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
1100 &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1101 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1102 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1103 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1104 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1105 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1106 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1107 &-11,-13,-15,-17,3649*0/
1108 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,
1109 &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,
1110 &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,
1111 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1112 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1113 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1114 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1115 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1116 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1117 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1118 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1119 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1120 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1121 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1122 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1123 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1124 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1125 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1126 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1127 &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/
1128 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1129 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1130 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1131 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1132 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1133 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1134 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1135 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1136 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1137 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1138 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1139 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1140 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1141 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1142 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1143 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1144 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1145 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1146 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1147 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1148 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1149 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1150 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1151 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1152 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1153 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1154 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1155 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1156 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1157 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1158 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1159 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1160 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1161 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1162 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1163 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1164 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1165 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1166 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1167 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1168 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1169 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1170 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1171 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1172 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1173 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1174 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1175 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1176 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1177 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1178 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1179 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1180 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1181 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1182 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1183 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1184 &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,
1185 &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,
1186 &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,
1187 &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/
1188 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1189 &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,
1190 &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,
1191 &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,
1192 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1193 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1194 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1195 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1196 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1197 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1198 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1199 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1200 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1201 &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,
1202 &-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,
1203 &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,
1204 &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,
1205 &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,
1206 &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,
1207 &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/
1208 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1209 &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,
1210 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1211 &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,
1212 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1213 &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,
1214 &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,
1215 &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,
1216 &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,
1217 &-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,
1218 &-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,
1219 &-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,
1220 &-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,
1221 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1222 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1223 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1224 &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,
1225 &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,
1226 &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,
1227 &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/
1228 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1229 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1230 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1231 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1232 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1233 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1234 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1235 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1236 &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,
1237 &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,
1238 &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,
1239 &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,
1240 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1241 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1242 &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,
1243 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1244 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1245 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1246 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1247 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1248 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1249 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1250 &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,
1251 &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,
1252 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1253 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1254 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1255 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1256 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1257 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1258 &-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,
1259 &-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,
1260 &-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,
1261 &-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,
1262 &-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,
1263 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1264 &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,
1265 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1266 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1267 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1268 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1269 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1270 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1271 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1272 &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,
1273 &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,
1274 &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,
1275 &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,
1276 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1277 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1278 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1279 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1280 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1281 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1282 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1283 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1284 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1285 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1286 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1287 &-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/
1288 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1289 &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,
1290 &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,
1291 &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,
1292 &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,
1293 &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,
1294 &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,
1295 &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,
1296 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1297 &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,
1298 &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,
1299 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1300 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1301 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1302 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1303 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1304 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1305 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1306 &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,
1307 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1308 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1309 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1310 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1311 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1312 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1313 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1314 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1315 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1316 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1317 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1318 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1320 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1321 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1322 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1323 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1324 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1325 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1326 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1327 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1328 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1329 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1330 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1331 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1332 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1333 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1334 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1335 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1336 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1337 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1338 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1339 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1340 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1341 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1342 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1343 &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,
1344 &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,
1345 &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,
1346 &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,
1347 &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,
1348 &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,
1349 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1350 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1351 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1352 &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,
1353 &-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,
1354 &-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,
1355 &-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,
1356 &-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,
1357 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1358 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1359 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1360 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1361 &-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,
1362 &-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,
1363 &-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,
1364 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1365 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1366 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1367 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1368 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1369 &-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,
1370 &-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,
1371 &-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,
1372 &-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,
1373 &-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,
1374 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1375 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1376 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1377 &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,
1378 &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,
1379 &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/
1380 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1381 &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,
1382 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1383 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1384 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1385 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1386 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1387 &-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,
1388 &-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,
1389 &-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,
1390 &-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,
1391 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1392 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1393 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1394 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1395 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1396 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1397 &-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,
1398 &-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,
1399 &-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/
1400 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1401 &-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,
1402 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1403 &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,
1404 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1405 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1406 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1407 &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,
1408 &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,
1409 &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,
1410 &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,
1411 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
1412 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1413 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1414 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1415 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1416 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1417 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1418 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1419 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1420 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1421 &-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,
1422 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1423 &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,
1424 &162*81,31*0,-211,111,6516*0/
1425 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1426 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1427 &3*111,-211,111,7193*0/
1429 C...PYDAT4, with particle names (character strings).
1430 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1431 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1432 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1433 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1434 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1435 &'junction',' ','system','cluster','string','indep.','CMshower',
1436 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1437 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1438 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1439 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1440 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1441 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1442 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1443 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1444 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1445 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1446 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1447 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1448 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1449 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1450 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1451 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1452 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1453 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1454 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1455 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1456 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1457 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1458 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1459 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1460 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1461 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1462 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1463 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1464 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1465 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1466 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1467 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1468 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1469 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1470 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1471 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1472 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1473 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1474 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1475 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1476 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',131*' '/
1477 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1478 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1479 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1480 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1481 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1482 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1483 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1484 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1485 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1486 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1487 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1488 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1489 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1490 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1491 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1492 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1493 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1494 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1495 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1496 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1497 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1498 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1499 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1500 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1501 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1502 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1503 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1504 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1505 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1506 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1507 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1508 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1509 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1510 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1511 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1512 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1513 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1514 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1515 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1516 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1517 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1518 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1519 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1520 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1523 C...PYDATR, with initial values for the random number generator.
1524 DATA MRPY/19780503,0,0,97,33,0/
1526 C...Default values for allowed processes and kinematics constraints.
1529 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1530 &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,
1533 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1534 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1535 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1536 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1537 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1538 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1539 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1540 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1541 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1542 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1543 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1544 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1545 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1546 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1547 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1548 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1551 C...Default values for main switches and parameters. Reset information.
1552 DATA (MSTP(I),I=1,100)/
1553 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1554 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1555 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1556 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1557 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1558 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1559 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1560 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1561 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1562 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1563 DATA (MSTP(I),I=101,200)/
1564 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1565 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1566 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1567 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1568 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1569 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1570 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1571 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1572 8 6, 414, 2007, 11, 19, 0, 0, 0, 0, 0,
1573 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1574 DATA (PARP(I),I=1,100)/
1575 & 0.25D0, 10D0, 8*0D0,
1576 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1578 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1579 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1581 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1582 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1583 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1584 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
1585 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1586 DATA (PARP(I),I=101,200)/
1587 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1588 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1589 2 1.0D0, 0.4D0, 8*0D0,
1591 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1592 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1593 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1594 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1595 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1596 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1598 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1604 C...Constants for the generation of the various processes.
1605 DATA (ISET(I),I=1,100)/
1606 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1607 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1608 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1609 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1610 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1611 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1612 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1613 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1614 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1615 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1616 DATA (ISET(I),I=101,200)/
1617 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1618 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1619 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1620 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1621 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1622 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1623 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1624 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1625 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1626 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1627 DATA (ISET(I),I=201,300)/
1628 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1629 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1630 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1631 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1632 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1633 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1634 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1635 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1636 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1637 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1638 DATA (ISET(I),I=301,500)/
1640 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1641 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1642 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1643 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1644 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1645 9 1, 1, 2, 2, 2, 5*-2,
1647 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1648 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1649 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1650 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1651 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1652 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1653 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1654 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1655 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1656 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1657 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1658 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1659 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1660 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1661 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1662 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1663 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1664 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1665 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1666 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1667 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1668 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1669 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1670 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1671 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1672 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1673 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1674 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1675 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1676 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1677 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1678 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1679 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1680 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1681 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1682 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1683 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1684 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1685 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1686 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1687 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1688 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1689 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1690 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1691 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1692 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1693 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1694 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1695 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1696 & 1000011, 1000011, 2000011, 2000011, 1000011,
1697 & 2000011, 1000013, 1000013, 2000013, 2000013,
1698 & 1000013, 2000013, 1000015, 1000015, 2000015,
1699 & 2000015, 1000015, 2000015, 1000011, 1000012,
1700 1 1000015, 1000016, 2000015, 1000016, 1000012,
1701 1 1000012, 1000016, 1000016, 0, 0,
1702 1 1000022, 1000022, 1000023, 1000023, 1000025,
1703 1 1000025, 1000035, 1000035, 1000022, 1000023,
1704 2 1000022, 1000025, 1000022, 1000035, 1000023,
1705 2 1000025, 1000023, 1000035, 1000025, 1000035,
1706 2 1000024, 1000024, 1000037, 1000037, 1000024,
1707 2 1000037, 1000022, 1000024, 1000023, 1000024,
1708 3 1000025, 1000024, 1000035, 1000024, 1000022,
1709 3 1000037, 1000023, 1000037, 1000025, 1000037,
1710 3 1000035, 1000037, 1000021, 1000022, 1000021,
1711 3 1000023, 1000021, 1000025, 1000021, 1000035/
1712 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1713 4 1000021, 1000024, 1000021, 1000037, 1000021,
1714 4 1000021, 1000021, 1000021, 0, 0,
1715 4 1000002, 1000022, 2000002, 1000022, 1000002,
1716 4 1000023, 2000002, 1000023, 1000002, 1000025,
1717 5 2000002, 1000025, 1000002, 1000035, 2000002,
1718 5 1000035, 1000001, 1000024, 2000005, 1000024,
1719 5 1000001, 1000037, 2000005, 1000037, 1000002,
1720 5 1000021, 2000002, 1000021, 0, 0,
1721 6 1000006, 1000006, 2000006, 2000006, 1000006,
1722 6 2000006, 1000006, 1000006, 2000006, 2000006,
1725 7 1000002, 1000002, 2000002, 2000002, 1000002,
1726 7 2000002, 1000002, 1000002, 2000002, 2000002,
1727 7 1000002, 2000002, 1000002, 1000002, 2000002,
1728 7 2000002, 1000002, 1000002, 2000002, 2000002/
1729 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1730 8 1000005, 1000002, 2000005, 2000002, 1000005,
1731 8 2000002, 1000005, 1000002, 2000005, 2000002,
1732 8 1000005, 2000002, 1000005, 1000005, 2000005,
1733 8 2000005, 1000005, 1000005, 2000005, 2000005,
1734 9 1000005, 1000005, 2000005, 2000005, 1000005,
1735 9 2000005, 1000005, 1000021, 2000005, 1000021,
1736 9 1000005, 2000005, 37, 25, 37,
1737 9 35, 36, 25, 36, 35,
1739 4 9900041, 0, 9900042, 0, 9900041,
1740 4 11, 9900042, 11, 9900041, 13,
1741 4 9900042, 13, 9900041, 15, 9900042,
1742 4 15, 9900041, 9900041, 9900042, 9900042/
1743 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1744 5 9900041, 0, 9900042, 0, 9900023,
1745 5 0, 9900024, 0, 0, 0,
1748 6 24, 24, 24, 3000211, 3000211,
1749 6 3000211, 22, 3000111, 22, 3000221,
1750 6 23, 3000111, 23, 3000221, 24,
1751 6 3000211, 0, 0, 24, 23,
1752 7 24, 3000111, 3000211, 23, 3000211,
1753 7 3000111, 22, 3000211, 23, 3000211,
1754 7 24, 3000111, 24, 3000221, 22,
1755 7 24, 22, 23, 23, 23,
1756 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1757 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1758 9 5000039, 0, 5000039, 0, 21,
1759 9 5000039, 0, 5000039, 21, 5000039,
1761 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1762 & 37, 6, 37, 6, 36*0,
1763 2 443, 21, 9900443, 21, 9900441,
1764 2 21, 9910441, 21, 0, 9900443,
1765 2 0, 9900441, 0, 9910441, 21,
1766 2 9900443, 21, 9900441, 21, 9910441,
1767 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1768 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1769 6 553, 21, 9900553, 21, 9900551,
1770 6 21, 9910551, 21, 0, 9900553,
1771 6 0, 9900551, 0, 9910551, 21,
1772 6 9900553, 21, 9900551, 21, 9910551,
1773 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1774 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1775 DATA COEF/10000*0D0/
1776 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1777 &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,
1778 &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,
1779 &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,
1780 &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,
1781 &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,
1782 &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,
1783 &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,
1784 &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,
1785 &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,
1786 &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/
1788 C...Treatment of resonances.
1789 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1790 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,131*0/
1792 C...Character constants: name of processes.
1793 DATA PROC(0)/ 'All included subprocesses '/
1794 DATA (PROC(I),I=1,20)/
1795 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1796 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1797 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1798 &' ', 'W+ + W- -> h0 ',
1799 &' ', 'f + f'' -> f + f'' (QFD) ',
1800 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1801 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1802 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1803 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1804 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1805 DATA (PROC(I),I=21,40)/
1806 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1807 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1808 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1809 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1810 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1811 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1812 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1813 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1814 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1815 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1816 DATA (PROC(I),I=41,60)/
1817 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1818 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1819 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1820 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1821 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1822 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1823 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1824 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1825 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1826 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1827 DATA (PROC(I),I=61,80)/
1828 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1829 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1830 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1831 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1832 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1833 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1834 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1835 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1836 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1837 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1838 DATA (PROC(I),I=81,100)/
1839 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1840 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1841 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1842 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1843 8'g + g -> chi_2c + g ', ' ',
1844 9'Elastic scattering ', 'Single diffractive (XB) ',
1845 9'Single diffractive (AX) ', 'Double diffractive ',
1846 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1848 9'q + gamma* -> q ', ' '/
1849 DATA (PROC(I),I=101,120)/
1850 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1851 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1852 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1853 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1854 &' ', 'f + fbar -> gamma + h0 ',
1855 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1856 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1857 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1858 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1860 DATA (PROC(I),I=121,140)/
1861 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1862 2'f + f'' -> f + f'' + h0 ',
1863 2'f + f'' -> f" + f"'' + h0 ',
1867 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1868 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1869 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1870 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1871 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1872 DATA (PROC(I),I=141,160)/
1873 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1874 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1875 4'q + l -> LQ ', 'e + gamma -> e* ',
1876 4'd + g -> d* ', 'u + g -> u* ',
1877 4'g + g -> eta_tc ', ' ',
1878 5'f + fbar -> H0 ', 'g + g -> H0 ',
1879 5'gamma + gamma -> H0 ', ' ',
1880 5' ', 'f + fbar -> A0 ',
1881 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1883 DATA (PROC(I),I=161,180)/
1884 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1885 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1886 6'f + fbar -> f'' + fbar'' (g/Z)',
1887 6'f +fbar'' -> f" + fbar"'' (W) ',
1888 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1889 6'q + qbar -> e + e* ', ' ',
1890 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1891 7'f + f'' -> f + f'' + H0 ',
1892 7'f + f'' -> f" + f"'' + H0 ',
1893 7' ', 'f + fbar -> Z0 + A0 ',
1894 7'f + fbar'' -> W+/- + A0 ',
1895 7'f + f'' -> f + f'' + A0 ',
1896 7'f + f'' -> f" + f"'' + A0 ',
1898 DATA (PROC(I),I=181,200)/
1899 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1900 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1901 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1902 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1903 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1904 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1905 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1906 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1909 DATA (PROC(I),I=201,220)/
1910 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1911 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1912 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1913 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1914 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1915 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1916 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1917 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1918 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1919 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1920 DATA (PROC(I),I=221,240)/
1921 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1922 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1923 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1924 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1925 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1926 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1927 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1928 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1929 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1930 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1931 DATA (PROC(I),I=241,260)/
1932 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1933 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1934 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1935 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1936 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1937 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1938 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1939 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1940 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1941 5'qj + g -> ~qj_R + ~g ', ' '/
1942 DATA (PROC(I),I=261,300)/
1943 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1944 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1945 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1948 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1949 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1950 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1951 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1952 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1953 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1954 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1955 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1956 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1957 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1958 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1959 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1960 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1961 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1962 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1963 DATA (PROC(I),I=301,340)/
1964 &'f + fbar -> H+ + H- ', 39*' '/
1965 DATA (PROC(I),I=341,380)/
1966 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1967 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1968 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1969 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1970 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1971 5'f + f -> f'' + f'' + H_L++/-- ',
1972 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1973 5'f + fbar'' -> W_R+/- ',5*' ',
1974 6' ', 'f + fbar -> W_L+ W_L- ',
1975 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1976 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1977 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1978 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1979 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1980 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1981 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1982 7'f + fbar'' -> W+/- pi_T0 ',
1983 7'f + fbar'' -> W+/- pi_T0'' ',
1984 7'f + fbar'' -> gamma W+/- (ETC)','f + fbar -> gamma Z0 (ETC)',
1985 7'f + fbar -> Z0 Z0 (ETC)'/
1986 DATA (PROC(I),I=381,420)/
1987 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1988 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1989 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1990 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1992 9'f + fbar -> G* ', 'g + g -> G* ',
1993 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1994 9'g + g -> g + G* ', ' ',
1996 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
1998 DATA (PROC(I),I=421,460)/
1999 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2000 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2001 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2002 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2003 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2004 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2005 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2006 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2007 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2008 3'q + q~ -> g + cc~[3P2(1)] ',
2010 DATA (PROC(I),I=461,500)/
2011 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2012 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2013 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2014 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2015 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2016 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2017 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2018 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2019 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2020 7'q + q~ -> g + bb~[3P2(1)] ',
2023 C...Cross sections and slope offsets.
2026 C...Supersymmetry switches and parameters.
2028 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2031 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2032 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2033 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2037 C...Initial values for R-violating SUSY couplings.
2038 C...Should not be changed here. See PYMSIN.
2043 C...Technicolor switches and parameters
2045 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2048 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2049 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2050 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2051 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2052 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2055 C...Data for histogramming routines.
2056 DATA IHIST/1000,20000,55,1/
2059 C...Data for SUSY Les Houches Accord.
2060 DATA CPRO/'PYTHIA ','PYTHIA '/
2061 DATA CVER/'6.4 ','6.4 '/
2063 DATA PARMIN/100*0D0/
2064 DATA RMSOFT/101*0D0/
2071 C*********************************************************************
2074 C...Check that BLOCK DATA PYDATA has been loaded.
2075 C...Should not be required, except that some compilers/linkers
2076 C...are pretty buggy in this respect.
2080 C...Double precision and integer declarations.
2081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2082 IMPLICIT INTEGER(I-N)
2083 INTEGER PYK,PYCHGE,PYCOMP
2085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2088 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2089 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2090 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2091 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2093 C...Check a few variables to see they have been sensibly initialized.
2094 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2095 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2097 C...If not, abort the run right away.
2098 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2099 WRITE(*,*) 'The program execution is stopped now!'
2106 C*********************************************************************
2109 C...A simple program (disguised as subroutine) to run at installation
2110 C...as a check that the program works as intended.
2112 SUBROUTINE PYTEST(MTEST)
2114 C...Double precision and integer declarations.
2115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2116 IMPLICIT INTEGER(I-N)
2117 INTEGER PYK,PYCHGE,PYCOMP
2119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2122 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2123 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2125 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2127 DIMENSION PSUM(5),PINI(6),PFIN(6)
2129 C...Save defaults for values that are changed.
2146 C...First part: loop over simple events to be generated.
2147 IF(MTEST.GE.1) CALL PYTABU(20)
2151 C...Reset parameter values. Switch on some nonstandard features.
2166 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2168 C...Ten events each for some single jets configurations.
2172 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2173 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2174 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2175 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2176 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2177 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2179 C...Ten events each for some simple jet systems; string fragmentation.
2180 ELSEIF(IEV.LE.130) THEN
2182 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2183 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2184 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2185 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2186 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2187 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2188 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2189 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2190 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2192 C...Seventy events with independent fragmentation and momentum cons.
2193 ELSEIF(IEV.LE.200) THEN
2195 MSTJ(2)=1+MOD(IEV-131,4)
2196 MSTJ(3)=1+MOD((IEV-131)/4,4)
2197 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2198 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2199 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2200 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2201 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2202 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2204 C...A hundred events with random jets (check invariant mass).
2205 ELSEIF(IEV.LE.300) THEN
2212 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2213 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2214 EJET=5D0+20D0*PYR(0)
2215 THETA=ACOS(2D0*PYR(0)-1D0)
2217 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2218 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2219 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2220 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2222 PSUM(J)=PSUM(J)+P(I,J)
2225 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2226 & (PSUM(5)+PARJ(32))**2) GOTO 100
2228 C...Fifty e+e- continuum events with matrix elements.
2229 ELSEIF(IEV.LE.350) THEN
2233 C...Fifty e+e- continuum event with varying shower options.
2234 ELSEIF(IEV.LE.400) THEN
2235 MSTJ(42)=1+MOD(IEV,2)
2236 MSTJ(43)=1+MOD(IEV/2,4)
2237 MSTJ(44)=MOD(IEV/8,3)
2240 C...Fifty e+e- continuum events with coherent shower.
2241 ELSEIF(IEV.LE.450) THEN
2242 CALL PYEEVT(0,500D0)
2244 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2246 CALL PYONIA(5,9.46D0)
2249 C...Generate event. Find total momentum, energy and charge.
2260 C...Check conservation of energy, momentum and charge;
2261 C...usually exact, but only approximate for single jets.
2264 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2266 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2267 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2268 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2271 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2273 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2275 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2276 & (PFIN(J),J=1,4),PFIN(6)
2278 C...Check that all KF codes are known ones, and that partons/particles
2279 C...satisfy energy-momentum-mass relation. Store particle statistics.
2281 IF(K(I,1).GT.20) GOTO 170
2282 IF(PYCOMP(K(I,2)).EQ.0) THEN
2283 WRITE(MSTU(11),5100) I
2286 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2287 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2289 WRITE(MSTU(11),5200) I
2293 IF(MTEST.GE.1) CALL PYTABU(21)
2295 C...List all erroneous events and some normal ones.
2296 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2297 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2299 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2303 C...Stop execution if too many errors.
2304 IF(MERR.NE.0) NERR=NERR+1
2306 WRITE(MSTU(11),6300)
2312 C...Summarize result of run.
2313 IF(MTEST.GE.1) CALL PYTABU(22)
2315 C...Reset commonblock variables changed during run.
2332 C...Second part: complete events of various kinds.
2333 C...Common initial values. Loop over initiating conditions.
2334 MSTP(122)=MAX(0,MIN(2,MTEST))
2335 MDCY(PYCOMP(111),1)=0
2338 C...Reset process type, kinematics cuts, and the flags used.
2355 C...Prompt photon production at fixed target.
2358 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2362 CALL PYINIT('FIXT','pi+','p',PZSUM)
2364 C...QCD processes at ISR energies.
2365 ELSEIF(IPROC.EQ.2) THEN
2371 CALL PYINIT('CMS','p','p',PESUM)
2373 C...W production + multiple interactions at CERN Collider.
2374 ELSEIF(IPROC.EQ.3) THEN
2383 CALL PYINIT('CMS','p','pbar',PESUM)
2385 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2386 ELSEIF(IPROC.EQ.4) THEN
2398 CALL PYINIT('CMS','p','pbar',PESUM)
2400 C...Higgs production at LHC.
2401 ELSEIF(IPROC.EQ.5) THEN
2413 CALL PYINIT('CMS','p','p',PESUM)
2415 C...Z' production at SSC.
2416 ELSEIF(IPROC.EQ.6) THEN
2425 CALL PYINIT('CMS','p','p',PESUM)
2427 C...W pair production at 1 TeV e+e- collider.
2428 ELSEIF(IPROC.EQ.7) THEN
2435 CALL PYINIT('CMS','e+','e-',PESUM)
2437 C...Deep inelastic scattering at a LEP+LHC ep collider.
2438 ELSEIF(IPROC.EQ.8) THEN
2451 CALL PYINIT('3MOM','p','e-',PESUM)
2454 C...Generate 20 events of each required type.
2458 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2460 C...Check conservation of energy/momentum/flavour.
2471 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2472 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2473 DEVQ=ABS(PFIN(6)-PINI(6))
2474 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2475 & DEVQ.GT.0.1D0) MERR=1
2476 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2477 & (PFIN(J),J=1,4),PFIN(6)
2479 C...Check that all KF codes are known ones, and that partons/particles
2480 C...satisfy energy-momentum-mass relation.
2482 IF(K(I,1).GT.20) GOTO 210
2483 IF(PYCOMP(K(I,2)).EQ.0) THEN
2484 WRITE(MSTU(11),5100) I
2487 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2489 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2490 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2491 WRITE(MSTU(11),5200) I
2496 C...Listing of erroneous events, and first event of each type.
2497 IF(MERR.GE.1) NERR=NERR+1
2499 WRITE(MSTU(11),6300)
2503 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2504 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2509 C...List statistics for each process type.
2510 IF(MTEST.GE.1) CALL PYSTAT(1)
2513 C...Summarize result of run.
2514 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2515 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2517 C...Format statements for output.
2518 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2519 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2520 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2521 &4(1X,F12.5),1X,F8.2)
2522 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2523 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2525 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2526 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2527 6400 FORMAT(5X,'Faulty event follows:')
2528 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2529 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2530 &5X,'This should not have happened!')
2535 C*********************************************************************
2538 C...Converts PYTHIA event record contents to or from
2539 C...the standard event record commonblock.
2541 SUBROUTINE PYHEPC(MCONV)
2543 C...Double precision and integer declarations.
2544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2545 IMPLICIT INTEGER(I-N)
2546 INTEGER PYK,PYCHGE,PYCOMP
2548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2551 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2552 C...HEPEVT commonblock.
2553 PARAMETER (NMXHEP=4000)
2554 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2555 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2556 DOUBLE PRECISION PHEP,VHEP
2559 C...Store HEPEVT commonblock size (for interfacing issues).
2562 C...Conversion from PYTHIA to standard, the easy part.
2565 IF(N.GT.NMXHEP) CALL PYERRM(8,
2566 & '(PYHEPC:) no more space in /HEPEVT/')
2570 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2571 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2572 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2573 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2577 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2591 C...Check if new event (from pileup).
2595 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2598 C...Fill in missing mother information.
2599 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2601 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2608 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2611 IF(I1.GE.I) CALL PYERRM(8,
2612 & '(PYHEPC:) translation of inconsistent event history')
2613 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2615 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2616 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2618 ELSEIF(K(I,2).EQ.94) THEN
2620 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2621 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2622 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2623 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2624 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2627 C...Fill in missing daughter information.
2628 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2629 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2630 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2634 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2636 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2637 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2638 IF(JDAHEP(1,I1).EQ.0) THEN
2645 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2646 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2649 C...Conversion from standard to PYTHIA, the easy part.
2651 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2652 & '(PYHEPC:) no more space in /PYJETS/')
2658 IF(ISTHEP(I).EQ.1) K(I,1)=1
2659 IF(ISTHEP(I).EQ.2) K(I,1)=11
2660 IF(ISTHEP(I).EQ.3) K(I,1)=21
2672 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2674 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2675 & PHEP(5,I)/PHEP(4,I)
2678 C...Fill in missing information on colour connection in jet systems.
2679 IF(ISTHEP(I).EQ.1) THEN
2682 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2683 IF(KQ.NE.0) NKQ=NKQ+1
2684 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2685 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2687 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2688 IF(K(I+1,2).EQ.21) K(I,1)=2
2692 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2693 & '(PYHEPC:) input parton configuration not colour singlet')
2698 C*********************************************************************
2701 C...Initializes the generation procedure; finds maxima of the
2702 C...differential cross-sections to be used for weighting.
2704 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2706 C...Double precision and integer declarations.
2707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2708 IMPLICIT INTEGER(I-N)
2709 INTEGER PYK,PYCHGE,PYCOMP
2711 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2712 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2713 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2714 COMMON/PYDAT4/CHAF(500,2)
2716 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2717 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2718 COMMON/PYINT1/MINT(400),VINT(400)
2719 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2720 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2721 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2722 &/PYINT1/,/PYINT2/,/PYINT5/
2723 C...Local arrays and character variables.
2724 DIMENSION ALAMIN(20),NFIN(20)
2725 CHARACTER*(*) FRAME,BEAM,TARGET
2726 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2728 C...Interface to PDFLIB.
2729 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2730 COMMON/LW50512/QCDL4,QCDL5
2733 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2734 CHARACTER*20 PARM(20)
2735 DATA VALUE/20*0D0/,PARM/20*' '/
2737 C...Data:Lambda and n_f values for parton distributions..
2738 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2739 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2741 DATA CHLH/'lepton','hadron'/
2743 C...Check that BLOCK DATA PYDATA has been loaded.
2746 C...Reset MINT and VINT arrays. Write headers.
2752 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2753 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2755 C...Reset error counters.
2760 C...Reset processes that should not be on.
2764 C...Select global FSR/ISR/UE parameter set = 'tune'
2765 C...See routine PYTUNE for details
2766 IF (MSTP(5).NE.0) THEN
2771 C...Call user process initialization routine.
2772 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2778 C...Maximum 4 generations; set maximum number of allowed flavours.
2779 MSTP(1)=MIN(4,MSTP(1))
2780 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2781 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2783 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2787 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2790 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2791 IPM=(5-ISIGN(1,I))/2
2793 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2794 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2796 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2801 C...Initialize parton distributions: PDFLIB.
2802 IF(MSTP(52).EQ.2) THEN
2806 VALUE(2)=MSTP(51)/1000
2808 VALUE(3)=MOD(MSTP(51),1000)
2811 CALL PDFSET_ALICE(PARM,VALUE)
2812 MINT(93)=1000000+MSTP(51)
2815 C...Choose Lambda value to use in alpha-strong.
2817 IF(MSTP(3).GE.2) THEN
2820 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2821 ALAM=ALAMIN(MSTP(51))
2823 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2826 ELSEIF(MSTP(52).EQ.2) THEN
2835 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2838 C...Initialize the SUSY generation: couplings, masses,
2839 C...decay modes, branching ratios, and so on.
2841 C...Initialize widths and partial widths for resonances.
2843 C...Set Z0 mass and width for e+e- routines.
2844 PARJ(123)=PMAS(23,1)
2845 PARJ(124)=PMAS(23,2)
2847 C...Identify beam and target particles and frame of process.
2851 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2852 IF(MINT(65).EQ.1) GOTO 170
2854 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2855 C...For e-gamma allow 2 alternatives.
2857 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2858 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2859 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2860 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2861 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2862 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2863 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2864 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2865 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2866 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2867 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2868 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2869 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2870 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2871 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2872 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2873 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2874 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2877 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2878 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2879 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2880 IF(MSTP(14).EQ.11) MINT(123)=0
2881 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2882 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2883 IF(MSTP(14).EQ.15) MINT(123)=2
2884 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2885 IF(MSTP(14).EQ.19) MINT(123)=3
2886 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2887 IF(MSTP(14).EQ.21) MINT(123)=0
2888 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2889 IF(MSTP(14).EQ.24) MINT(123)=1
2890 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2891 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2892 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2895 C...Set up kinematics of process.
2898 C...Set up kinematics for photons inside leptons.
2899 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2901 C...Precalculate flavour selection weights.
2904 C...Loop over gamma-p or gamma-gamma alternatives.
2907 DO 160 IGA=1,MINT(121)
2911 C...Select partonic subprocesses to be included in the simulation.
2918 C...Count number of subprocesses on.
2921 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2922 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2924 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2925 & MSUB(ISUB).EQ.1) THEN
2926 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2928 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2929 WRITE(MSTU(11),5300) ISUB
2931 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2932 WRITE(MSTU(11),5400) ISUB
2934 ELSEIF(MSUB(ISUB).EQ.1) THEN
2939 C...Stop or raise warning flag if no subprocesses on.
2940 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2941 IF(MSTP(127).NE.1) THEN
2942 WRITE(MSTU(11),5500)
2945 WRITE(MSTU(11),5700)
2949 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2950 MSAV48=MSAV48+MINT(48)
2952 C...Reset variables for cross-section calculation.
2960 C...Find parametrized total cross-sections.
2964 C...Maxima of differential cross-sections.
2965 IF(MSTP(121).LE.1) CALL PYMAXI
2967 C...Initialize possibility of pileup events.
2968 IF(MINT(121).GT.1) MSTP(131)=0
2969 IF(MSTP(131).NE.0) CALL PYPILE(1)
2971 C...Initialize multiple interactions with variable impact parameter.
2972 IF(MINT(50).EQ.1) THEN
2973 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2974 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2975 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2976 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2984 C...Save results for gamma-p and gamma-gamma alternatives.
2985 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2988 C...Initialization finished.
2989 IF(MSAV48.EQ.0) THEN
2990 IF(MSTP(127).NE.1) THEN
2991 WRITE(MSTU(11),5500)
2994 WRITE(MSTU(11),5700)
2998 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3000 C...Formats for initialization information.
3001 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3002 &'routines',1X,17('*'))
3003 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3004 &'-',A6,' interactions.'/1X,'Execution stopped!')
3005 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3006 &1X,'Execution stopped!')
3007 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3008 &1X,'Execution stopped!')
3009 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3010 &1X,'Execution stopped.')
3011 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3013 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3014 &1X,'Execution will stop if you try to generate events.')
3019 C*********************************************************************
3022 C...Administers the generation of a high-pT event via calls to
3023 C...a number of subroutines.
3027 C...Double precision and integer declarations.
3028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3029 IMPLICIT INTEGER(I-N)
3030 INTEGER PYK,PYCHGE,PYCOMP
3032 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3033 COMMON/PYCTAG/NCT,MCT(4000,2)
3034 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3035 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3036 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3037 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3038 COMMON/PYINT1/MINT(400),VINT(400)
3039 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3040 COMMON/PYINT4/MWID(500),WIDS(500,5)
3041 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3042 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3043 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3047 C...Optionally let PYEVNW do the whole job.
3048 IF(MSTP(81).GE.20) THEN
3053 C...Stop if no subprocesses on.
3054 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3055 WRITE(MSTU(11),5100)
3059 C...Initial values for some counters.
3072 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3076 C...Let called routines know call is from PYEVNT (not PYEVNW).
3078 IF (MSTP(81).GE.10) MINT(35)=2
3080 C...If variable energies: redo incoming kinematics and cross-section.
3082 IF(MSTP(171).EQ.1) THEN
3084 IF(MSTI(61).EQ.1) THEN
3088 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3092 C...Loop over number of pileup events; check space left.
3093 IF(MSTP(131).LE.0) THEN
3099 DO 270 IPILE=1,NPILE
3100 IF(MINT(84)+100.GE.MSTU(4)) THEN
3102 & '(PYEVNT:) no more space in PYJETS for pileup events')
3103 IF(MSTU(21).GE.1) GOTO 280
3107 C...Generate variables of hard scattering.
3111 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3117 IF(MSTI(61).EQ.1) THEN
3121 IF(MINT(51).EQ.2) RETURN
3123 IF(MSTP(111).EQ.-1) GOTO 260
3125 C...Loopback point if PYPREP fails, especially for junction topologies.
3131 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3132 C...Hard scattering (including low-pT):
3133 C...reconstruct kinematics and colour flow of hard scattering.
3138 IF(MINT(51).EQ.1) GOTO 100
3141 IF(ISUB.EQ.95) GOTO 140
3143 C...Reset statistics on activity in event.
3149 C...Showering of initial state partons (optional).
3153 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3154 & CALL PYSSPA(IPU1,IPU2)
3156 IF(MINT(51).EQ.1) GOTO 100
3158 C...Showering of final state partons (optional).
3161 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3165 IF(ISET(ISUB).EQ.5) IPU4=-3
3167 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3168 CALL PYSHOW(IPU3,IPU4,QMAX)
3169 ELSEIF(ISET(ISUB).EQ.11) THEN
3174 C...Allow possibility for user to abort event generation.
3176 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3177 IF(IVETO.EQ.1) GOTO 100
3179 C...Decay of final state resonances.
3181 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3182 IF(MINT(51).EQ.1) GOTO 100
3186 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3187 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3188 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3190 IF(MINT(51).EQ.1) GOTO 100
3193 C...Beam remnant flavour and colour assignments - new scheme.
3195 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3197 IF(MINT(51).EQ.1) GOTO 100
3199 C...Primordial kT and beam remnant momentum sharing - new scheme.
3201 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3203 IF(MINT(51).EQ.1) GOTO 100
3204 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3206 C...Multiple interactions - PYTHIA 6.2 style.
3207 ELSEIF(MINT(111).NE.12) THEN
3208 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3213 C...Hadron remnants and primordial kT.
3214 CALL PYREMN(IPU1,IPU2)
3215 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3217 IF(MINT(51).EQ.1) GOTO 100
3220 ELSEIF(ISUB.NE.99) THEN
3221 C...Diffractive and elastic scattering.
3225 C...DIS scattering (photon flux external).
3227 IF(MINT(51).EQ.1) GOTO 100
3230 C...Check that no odd resonance left undecayed.
3232 IF(MSTP(111).GE.1) THEN
3234 DO 150 I=MINT(84)+1,NFIX
3235 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3236 & K(I,2).NE.22) THEN
3238 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3240 IF(MINT(51).EQ.1) GOTO 100
3246 C...Boost hadronic subsystem to overall rest frame.
3247 C..(Only relevant when photon inside lepton beam.)
3248 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3250 C...Recalculate energies from momenta and masses (if desired).
3251 IF(MSTP(113).GE.1) THEN
3252 DO 160 I=MINT(83)+1,N
3253 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3254 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3259 C...Colour reconnection before string formation
3260 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3262 C...Rearrange partons along strings, check invariant mass cuts.
3264 IF(MSTP(111).LE.0) MSTJ(14)=-1
3265 CALL PYPREP(MINT(84)+1)
3267 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3271 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3272 IF (MINT(51).EQ.1) GOTO 100
3273 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3274 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3275 DO 190 I=MINT(84)+1,N
3276 IF(K(I,2).EQ.94) THEN
3277 DO 180 I1=I+1,MIN(N,I+10)
3278 IF(K(I1,3).EQ.I) THEN
3279 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3280 IF(K(I1,3).EQ.0) THEN
3281 DO 170 II=MINT(84)+1,I-1
3282 IF(K(II,2).EQ.K(I1,2)) THEN
3283 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3284 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3287 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3295 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3296 IF(MSTP(125).EQ.0) MINT(4)=0
3297 DO 210 I=MINT(83)+1,N
3298 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3300 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3301 IF(K(I1,3).EQ.I) K(I,5)=I1
3307 C...Introduce separators between sections in PYLIST event listing.
3308 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3311 ELSEIF(IPILE.EQ.1) THEN
3318 C...Go back to lab frame (needed for vertices, also in fragmentation).
3321 C...Set nonvanishing production vertex (optional).
3322 IF(MSTP(151).EQ.1) THEN
3324 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3325 & SIN(PARU(2)*PYR(0))
3327 DO 240 I=MINT(83)+1,N
3329 V(I,J)=V(I,J)+VTX(J)
3334 C...Perform hadronization (if desired).
3335 IF(MSTP(111).GE.1) THEN
3337 IF(MSTU(24).NE.0) GOTO 100
3339 IF(MSTP(113).GE.1) THEN
3341 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3342 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3345 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3347 C...Store event information and calculate Monte Carlo estimates of
3348 C...subprocess cross-sections.
3349 260 IF(IPILE.EQ.1) CALL PYDOCU
3351 C...Set counters for current pileup event and loop to next one.
3353 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3354 IF(MSTU70.LT.10) THEN
3359 MINT(84)=N+MSTP(126)
3360 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3363 C...Generic information on pileup events. Reconstruct missing history.
3364 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3368 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3372 C...Transform to the desired coordinate frame.
3373 280 CALL PYFRAM(MSTP(124))
3378 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3379 &1X,'Execution stopped.')
3384 C*********************************************************************
3387 C...Administers the generation of a high-pT event via calls to
3388 C...a number of subroutines for the new multiple interactions and
3389 C...showering framework.
3393 C...Double precision and integer declarations.
3394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3395 IMPLICIT INTEGER(I-N)
3396 INTEGER PYK,PYCHGE,PYCOMP
3398 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3399 COMMON/PYCTAG/NCT,MCT(4000,2)
3400 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3401 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3402 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3403 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3404 COMMON/PYINT1/MINT(400),VINT(400)
3405 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3406 COMMON/PYINT4/MWID(500),WIDS(500,5)
3407 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3408 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3409 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3410 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3411 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3412 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3416 C...Stop if no subprocesses on.
3417 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3418 WRITE(MSTU(11),5100)
3422 C...Initial values for some counters.
3435 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3439 C...Let called routines know call is from PYEVNW (not PYEVNT).
3442 C...If variable energies: redo incoming kinematics and cross-section.
3444 IF(MSTP(171).EQ.1) THEN
3446 IF(MSTI(61).EQ.1) THEN
3450 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3454 C...Loop over number of pileup events; check space left.
3455 IF(MSTP(131).LE.0) THEN
3461 DO 300 IPILE=1,NPILE
3462 IF(MINT(84)+100.GE.MSTU(4)) THEN
3464 & '(PYEVNW:) no more space in PYJETS for pileup events')
3465 IF(MSTU(21).GE.1) GOTO 310
3469 C...Generate variables of hard scattering.
3473 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3480 IF(MSTI(61).EQ.1) THEN
3484 IF(MINT(51).EQ.2) RETURN
3486 IF(MSTP(111).EQ.-1) GOTO 290
3488 C...Loopback point if PYPREP fails, especially for junction topologies.
3494 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3495 C...Hard scattering (including low-pT):
3496 C...reconstruct kinematics and colour flow of hard scattering.
3501 IF(MINT(51).EQ.1) GOTO 100
3505 C...Intertwined initial state showers and multiple interactions.
3506 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3507 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3509 IF (MINT(47).LT.2) MSTP(61)=0
3511 IF (MINT(50).EQ.0) MSTP(81)=0
3512 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3513 & MINT(111).NE.12) THEN
3514 C...Absolute max pT2 scale for evolution: phase space limit.
3515 PT2MXS=0.25D0*VINT(2)
3516 C...Check if more constrained by ISR and MI max scales:
3517 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3518 C...Loopback point in case of failure in evolution.
3522 IF(LOOP.GT.100) THEN
3523 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3524 & //'multiple interactions.')
3529 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3530 C...once per event. (E.g. compute constants and save variables to be
3531 C...restored later in case of failure.)
3532 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3534 C...Initialize interleaved MI/ISR/JI evolution.
3535 C...PT2MAX: absolute upper limit for evolution - Initialization may
3536 C... return a PT2MAX which is lower than this.
3537 C...PT2MIN: absolute lower limit for evolution - Initialization may
3538 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3541 CALL PYEVOL(0,PT2MAX,PT2MIN)
3542 IF (MINT(51).EQ.1) GOTO 130
3544 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3545 C...In principle factorized, so can be stopped and restarted.
3546 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3547 C PT2MED=MAX(10D0**2,PT2MIN)
3548 C CALL PYEVOL(1,PT2MAX,PT2MED)
3549 C IF (MINT(51).EQ.1) GOTO 160
3551 CALL PYEVOL(1,PT2MAX,PT2MIN)
3552 IF (MINT(51).EQ.1) GOTO 130
3554 C...Finalize interleaved MI/ISR/JI evolution.
3555 CALL PYEVOL(2,PT2MAX,PT2MIN)
3556 IF (MINT(51).EQ.1) GOTO 130
3561 IF(MINT(51).EQ.1) GOTO 100
3562 C...(MINT(52) is actually obsolete in this routine. Set anyway
3563 C...to ensure PYDOCU stable.)
3567 C...Beam remnants - new scheme.
3568 140 IF(MINT(50).EQ.1) THEN
3569 IF (ISUB.EQ.95) MINT(31)=1
3571 C...Beam remnant flavour and colour assignments - new scheme.
3573 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3575 IF(MINT(51).EQ.1) GOTO 100
3577 C...Primordial kT and beam remnant momentum sharing - new scheme.
3579 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3581 IF(MINT(51).EQ.1) GOTO 100
3582 IF (ISUB.EQ.95) MINT(31)=0
3583 ELSEIF(MINT(111).NE.12) THEN
3584 C...Hadron remnants and primordial kT - old model.
3585 C...Happens e.g. for direct photon on one side.
3588 CALL PYREMN(IPU1,IPU2)
3589 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3591 IF(MINT(51).EQ.1) GOTO 100
3592 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3593 DO 160 I=MINT(53)+1,N
3595 IDA=MOD(K(I,KCS),MSTU(5))
3597 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3603 C...Instruct PYPREP to use colour tags
3607 DO 350 I=MINT(84)+1,N
3609 C...Look for coloured string endpoint, or (later) leftover gluon.
3610 IF (K(I,1).NE.3) GOTO 350
3612 IF(KC.EQ.0) GOTO 350
3614 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3616 C... Pick up loose string end with no previous tag.
3618 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3619 IF(MCT(I,KCS-3).NE.0) GOTO 350
3621 CALL PYCTTR(I,KCS,I)
3622 IF(MINT(51).NE.0) RETURN
3626 C...Now delete any colour processing information if set (since partons
3627 C...otherwise not FS showered!)
3628 DO 170 I=MINT(84)+1,N
3630 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3631 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3636 C...Showering of final state partons (optional).
3639 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3642 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3643 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3644 C...External processes: handle successive showers.
3645 ELSEIF(ISET(ISUB).EQ.11) THEN
3650 C...Allow possibility for user to abort event generation.
3652 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3653 IF(IVETO.EQ.1) GOTO 100
3656 C...Decay of final state resonances.
3658 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3660 IF(MINT(51).NE.0) GOTO 100
3663 IF(MINT(51).EQ.1) GOTO 100
3665 ELSEIF(ISUB.NE.99) THEN
3666 C...Diffractive and elastic scattering.
3670 C...DIS scattering (photon flux external).
3672 IF(MINT(51).EQ.1) GOTO 100
3675 C...Check that no odd resonance left undecayed.
3677 IF(MSTP(111).GE.1) THEN
3679 DO 180 I=MINT(84)+1,NFIX
3680 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3681 & K(I,2).NE.22) THEN
3683 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3685 IF(MINT(51).EQ.1) GOTO 100
3691 C...Boost hadronic subsystem to overall rest frame.
3692 C..(Only relevant when photon inside lepton beam.)
3693 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3695 C...Recalculate energies from momenta and masses (if desired).
3696 IF(MSTP(113).GE.1) THEN
3697 DO 190 I=MINT(83)+1,N
3698 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3699 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3704 C...Colour reconnection before string formation
3705 CALL PYFSCR(MINT(84)+1)
3707 C...Rearrange partons along strings, check invariant mass cuts.
3709 IF(MSTP(111).LE.0) MSTJ(14)=-1
3710 CALL PYPREP(MINT(84)+1)
3712 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3716 IF(MINT(51).EQ.1) GOTO 110
3717 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3718 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3719 DO 220 I=MINT(84)+1,N
3720 IF(K(I,2).EQ.94) THEN
3721 DO 210 I1=I+1,MIN(N,I+10)
3722 IF(K(I1,3).EQ.I) THEN
3723 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3724 IF(K(I1,3).EQ.0) THEN
3725 DO 200 II=MINT(84)+1,I-1
3726 IF(K(II,2).EQ.K(I1,2)) THEN
3727 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3728 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3731 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3739 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3740 IF(MSTP(125).EQ.0) MINT(4)=0
3741 DO 240 I=MINT(83)+1,N
3742 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3744 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3745 IF(K(I1,3).EQ.I) K(I,5)=I1
3751 C...Introduce separators between sections in PYLIST event listing.
3752 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3755 ELSEIF(IPILE.EQ.1) THEN
3762 C...Go back to lab frame (needed for vertices, also in fragmentation).
3765 C...Set nonvanishing production vertex (optional).
3766 IF(MSTP(151).EQ.1) THEN
3768 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3769 & SIN(PARU(2)*PYR(0))
3771 DO 270 I=MINT(83)+1,N
3773 V(I,J)=V(I,J)+VTX(J)
3778 C...Perform hadronization (if desired).
3779 IF(MSTP(111).GE.1) THEN
3781 IF(MSTU(24).NE.0) GOTO 100
3783 IF(MSTP(113).GE.1) THEN
3785 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3786 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3789 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3791 C...Store event information and calculate Monte Carlo estimates of
3792 C...subprocess cross-sections.
3793 290 IF(IPILE.EQ.1) CALL PYDOCU
3795 C...Set counters for current pileup event and loop to next one.
3797 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3798 IF(MSTU70.LT.10) THEN
3803 MINT(84)=N+MSTP(126)
3804 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3807 C...Generic information on pileup events. Reconstruct missing history.
3808 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3812 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3816 C...Transform to the desired coordinate frame.
3817 310 CALL PYFRAM(MSTP(124))
3822 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3823 &1X,'Execution stopped.')
3829 C***********************************************************************
3832 C...Prints out information about cross-sections, decay widths, branching
3833 C...ratios, kinematical limits, status codes and parameter values.
3835 SUBROUTINE PYSTAT(MSTAT)
3837 C...Double precision and integer declarations.
3838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3839 IMPLICIT INTEGER(I-N)
3840 INTEGER PYK,PYCHGE,PYCOMP
3841 C...Parameter statement to help give large particle numbers.
3842 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3843 &KEXCIT=4000000,KDIMEN=5000000)
3844 PARAMETER (EPS=1D-3)
3846 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3847 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3848 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3849 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3851 COMMON/PYINT1/MINT(400),VINT(400)
3852 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3853 COMMON/PYINT4/MWID(500),WIDS(500,5)
3854 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3855 COMMON/PYINT6/PROC(0:500)
3856 CHARACTER PROC*28, CHTMP*16
3857 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3858 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3859 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3860 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3861 C...Local arrays, character variables and data.
3862 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3863 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3864 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3865 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3866 CHARACTER*24 CHD0, CHDC(10)
3867 CHARACTER*6 DNAME(3)
3869 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3870 &'VMD/hadron * anomalous ','direct * direct ',
3871 &'direct * anomalous ','anomalous * anomalous '/
3872 DATA DISGA/'e * VMD','e * anomalous'/
3874 &'direct * direct ','direct * VMD ',
3875 &'direct * anomalous ','VMD * direct ',
3876 &'VMD * VMD ','VMD * anomalous ',
3877 &'anomalous * direct ','anomalous * VMD ',
3878 &'anomalous * anomalous ','DIS * VMD ',
3879 &'DIS * anomalous ','VMD * DIS ',
3880 &'anomalous * DIS '/
3882 &'direct * direct ','direct * resolved ',
3883 &'resolved * direct ','resolved * resolved '/
3885 &'direct * hadron ','resolved * hadron '/
3887 &'VMD * hadron ','direct * hadron ',
3888 &'anomalous * hadron ','DIS * hadron '/
3889 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3890 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3891 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3892 &' y*_small ',' eta*_large ',' eta*_small ',
3893 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3894 &' x_2 ',' x_F ',' cos(theta_hard) ',
3895 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3896 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3898 DATA DNAME /'q ','lepton','nu '/
3902 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3903 WRITE(MSTU(11),5000)
3904 WRITE(MSTU(11),5100)
3905 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3907 IF(MSUB(I).NE.1) GOTO 100
3908 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3910 IF(MINT(121).GT.1) THEN
3911 WRITE(MSTU(11),5300)
3912 DO 110 IGA=1,MINT(121)
3914 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3915 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3917 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3918 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3920 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3921 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3923 ELSEIF(MINT(121).EQ.4) THEN
3924 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3926 ELSEIF(MINT(121).EQ.2) THEN
3927 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3930 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3936 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3937 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3939 C...Decay widths and branching ratios.
3940 ELSEIF(MSTAT.EQ.2) THEN
3941 WRITE(MSTU(11),5500)
3942 WRITE(MSTU(11),5600)
3945 CALL PYNAME(KF,CHKF)
3948 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3949 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3950 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3951 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3952 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3954 IF(MWID(KC).LE.0) GOTO 140
3955 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3956 & KF/KSUSY1.EQ.2)) GOTO 140
3958 C...Off-shell branchings.
3961 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3962 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3963 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3964 DO 120 J=1,MDCY(KC,3)
3967 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3968 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3970 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3971 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3972 CALL PYNAME(KFDP(IDC,1),CHD1)
3973 CALL PYNAME(KFDP(IDC,2),CHD2)
3974 IF(KFDP(IDC,3).EQ.0) THEN
3975 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3976 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3977 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3979 CALL PYNAME(KFDP(IDC,3),CHD3)
3980 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3981 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3982 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3985 C...On-shell decays.
3987 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3989 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3990 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3991 & STATE(MDCY(KC,1)),BRFIN
3992 DO 130 J=1,MDCY(KC,3)
3995 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3996 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3998 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3999 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4001 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4003 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4004 CALL PYNAME(KFDP(IDC,1),CHD1)
4005 CALL PYNAME(KFDP(IDC,2),CHD2)
4006 IF(KFDP(IDC,3).EQ.0) THEN
4007 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4008 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4009 & CHD2(1:10),WDTP(J),BRPRI,
4010 & STATE(MDME(IDC,1)),BRFIN
4012 CALL PYNAME(KFDP(IDC,3),CHD3)
4013 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4014 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4015 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4016 & STATE(MDME(IDC,1)),BRFIN
4021 WRITE(MSTU(11),6000)
4023 C...Allowed incoming partons/particles at hard interaction.
4024 ELSEIF(MSTAT.EQ.3) THEN
4025 WRITE(MSTU(11),6100)
4026 CALL PYNAME(MINT(11),CHAU)
4028 CALL PYNAME(MINT(12),CHAU)
4030 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4034 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4035 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4037 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4040 WRITE(MSTU(11),6400)
4042 C...User-defined limits on kinematical variables.
4043 ELSEIF(MSTAT.EQ.4) THEN
4044 WRITE(MSTU(11),6500)
4045 WRITE(MSTU(11),6600)
4047 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4048 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4049 PTHMIN=MAX(CKIN(3),CKIN(5))
4051 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4052 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4053 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4055 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4058 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4059 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4060 WRITE(MSTU(11),7000)
4062 C...Status codes and parameter values.
4063 ELSEIF(MSTAT.EQ.5) THEN
4064 WRITE(MSTU(11),7100)
4065 WRITE(MSTU(11),7200)
4067 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4071 C...List of all processes implemented in the program.
4072 ELSEIF(MSTAT.EQ.6) THEN
4073 WRITE(MSTU(11),7400)
4074 WRITE(MSTU(11),7500)
4076 IF(ISET(I).LT.0) GOTO 180
4077 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4079 WRITE(MSTU(11),7700)
4081 ELSEIF(MSTAT.EQ.7) THEN
4082 WRITE (MSTU(11),8000)
4088 KFSUSY=ILR*KSUSY1+KFSM
4091 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4097 CALL PYNAME(KFSUSY,CHTMP)
4099 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4100 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4101 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4103 DO 200 J=1,MDCY(KC,3)
4105 ID1=IABS(KFDP(IDC,1))
4106 ID2=IABS(KFDP(IDC,2))
4107 IF (KFDP(IDC,3).EQ.0) THEN
4108 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4109 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4110 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4111 NMODES(1)=NMODES(1)+1
4112 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4113 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4114 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4115 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4116 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4117 NMODES(2)=NMODES(2)+1
4118 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4119 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4120 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4121 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4122 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4123 NMODES(3)=NMODES(3)+1
4124 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4125 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4131 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4137 CALL PYNAME(KFSUSY,CHTMP)
4139 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4140 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4142 DO 220 J=1,MDCY(KC,3)
4144 ID1=IABS(KFDP(IDC,1))
4145 ID2=IABS(KFDP(IDC,2))
4146 IF (KFDP(IDC,3).EQ.0) THEN
4147 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4148 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4149 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4150 NMODES(1)=NMODES(1)+1
4151 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4152 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4153 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4154 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4155 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4156 NMODES(2)=NMODES(2)+1
4157 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4158 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4164 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4170 CALL PYNAME(KFSUSY,CHTMP)
4172 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4173 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4175 DO 240 J=1,MDCY(KC,3)
4177 ID1=IABS(KFDP(IDC,1))
4178 ID2=IABS(KFDP(IDC,2))
4179 IF (KFDP(IDC,3).EQ.0) THEN
4180 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4181 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4182 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4183 NMODES(1)=NMODES(1)+1
4184 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4185 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4187 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4188 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4189 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4190 NMODES(2)=NMODES(2)+1
4191 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4192 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4197 C...SNEUTRINO DECAYS
4198 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4205 CALL PYNAME(KFSUSY,CHTMP)
4207 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4208 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4210 DO 260 J=1,MDCY(KC,3)
4212 ID1=IABS(KFDP(IDC,1))
4213 ID2=IABS(KFDP(IDC,2))
4214 IF (KFDP(IDC,3).EQ.0) THEN
4215 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4216 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4217 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4218 NMODES(1)=NMODES(1)+1
4219 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4220 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4222 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4223 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4224 NMODES(2)=NMODES(2)+1
4225 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4226 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4227 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4232 IF (NRVDC.NE.0) THEN
4234 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4235 NMODES(0)=NMODES(0)+NMODES(I)
4243 C...NEUTRALINO DECAYS
4244 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4250 CALL PYNAME(KFSUSY,CHTMP)
4252 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4253 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4254 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4255 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4257 DO 310 J=1,MDCY(KC,3)
4259 ID1=IABS(KFDP(IDC,1))
4260 ID2=IABS(KFDP(IDC,2))
4261 ID3=IABS(KFDP(IDC,3))
4262 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4263 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4264 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4265 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4266 NMODES(1)=NMODES(1)+1
4267 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4268 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4269 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4270 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4271 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4272 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4273 NMODES(2)=NMODES(2)+1
4274 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4275 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4276 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4277 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4278 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4279 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4280 NMODES(3)=NMODES(3)+1
4281 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4282 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4283 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4284 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4285 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4286 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4287 NMODES(4)=NMODES(4)+1
4288 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4289 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4294 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4300 CALL PYNAME(KFSUSY,CHTMP)
4302 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4303 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4304 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4305 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4306 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4308 DO 330 J=1,MDCY(KC,3)
4310 ID1=IABS(KFDP(IDC,1))
4311 ID2=IABS(KFDP(IDC,2))
4312 ID3=IABS(KFDP(IDC,3))
4313 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4314 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4315 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4316 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4317 NMODES(1)=NMODES(1)+1
4318 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4319 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4320 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4321 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4322 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4323 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4324 NMODES(1)=NMODES(1)+1
4325 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4326 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4327 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4328 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4329 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4330 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4331 NMODES(2)=NMODES(2)+1
4332 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4333 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4334 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4335 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4336 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4337 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4338 NMODES(3)=NMODES(3)+1
4339 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4340 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4341 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4342 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4343 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4344 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4345 NMODES(3)=NMODES(3)+1
4346 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4347 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4348 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4349 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4350 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4351 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4352 NMODES(4)=NMODES(4)+1
4353 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4354 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4355 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4356 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4357 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4358 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4359 NMODES(4)=NMODES(4)+1
4360 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4361 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4362 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4363 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4364 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4365 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4366 NMODES(5)=NMODES(5)+1
4367 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4368 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4369 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4370 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4371 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4372 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4373 NMODES(5)=NMODES(5)+1
4374 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4375 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4380 IF (KFSM.EQ.21) THEN
4386 CALL PYNAME(KFSUSY,CHTMP)
4388 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4389 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4390 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4392 DO 350 J=1,MDCY(KC,3)
4394 ID1=IABS(KFDP(IDC,1))
4395 ID2=IABS(KFDP(IDC,2))
4396 ID3=IABS(KFDP(IDC,3))
4397 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4398 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4399 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4400 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4401 NMODES(1)=NMODES(1)+1
4402 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4403 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4404 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4405 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4406 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4407 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4408 NMODES(2)=NMODES(2)+1
4409 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4410 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4411 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4412 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4413 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4414 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4415 NMODES(3)=NMODES(3)+1
4416 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4417 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4422 IF (NRVDC.NE.0) THEN
4424 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4425 NMODES(0)=NMODES(0)+NMODES(I)
4429 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4431 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4432 WRITE (MSTU(11),8500)
4436 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4437 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4441 WRITE (MSTU(11),8600)
4445 C...Formats for printouts.
4446 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4447 &'Events and Cross-sections',1X,9('*'))
4448 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4449 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4450 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4451 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4452 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4453 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4455 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4457 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4458 &1X,'I',34X,'I',28X,'I',12X,'I')
4459 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4460 &1X,'********* Total number of errors, excluding junctions =',
4461 &1X,I8,' *************'/
4462 &1X,'********* Total number of errors, including junctions =',
4463 &1X,I8,' *************'/
4464 &1X,'********* Total number of warnings = ',
4465 &1X,I8,' *************'/
4466 &1X,'********* Fraction of events that fail fragmentation ',
4467 &'cuts =',1X,F8.5,' *********'/)
4468 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4469 &'Ratios',1X,27('*'))
4470 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4471 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4472 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4473 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4475 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4476 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4477 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4478 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4479 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4480 &1P,D10.3,0P,1X,'I')
4481 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4482 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4483 &1P,D10.3,0P,1X,'I')
4484 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4485 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4486 &'Particles at Hard Interaction',1X,7('*'))
4487 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4488 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4489 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4490 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4491 &78('=')/1X,'I',38X,'I',37X,'I')
4492 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4493 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4494 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4495 &'Kinematical Variables',1X,12('*'))
4496 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4497 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4499 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4500 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4501 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4502 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4503 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4504 &'Parameter Values',1X,12('*'))
4505 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4507 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4508 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4510 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4511 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4512 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4513 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4514 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4516 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4517 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4518 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4519 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4520 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4521 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4522 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4523 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4524 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4526 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4527 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4528 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4530 & 1X,'R-Violating couplings',1X/ 1X /
4532 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4533 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4534 & ,'I',15X,'I',15X,'I',15X,'I')
4535 8600 FORMAT(1X,55('='))
4536 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4537 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4542 C*********************************************************************
4545 C...Administers the hard-process generation required for output to the
4546 C...Les Houches event record.
4550 C...Double precision and integer declarations.
4551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4552 IMPLICIT INTEGER(I-N)
4553 INTEGER PYK,PYCHGE,PYCOMP
4556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4557 COMMON/PYCTAG/NCT,MCT(4000,2)
4558 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4559 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4560 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4562 COMMON/PYINT1/MINT(400),VINT(400)
4563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4564 COMMON/PYINT4/MWID(500),WIDS(500,5)
4565 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4566 &/PYINT1/,/PYINT2/,/PYINT4/
4568 C...HEPEUP for output.
4570 PARAMETER (MAXNUP=500)
4571 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4572 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4573 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4574 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4575 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4578 C...Stop if no subprocesses on.
4579 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4580 WRITE(MSTU(11),5100)
4584 C...Special flags for hard-process generation only.
4590 C...Initial values for some counters.
4601 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4604 C...If variable energies: redo incoming kinematics and cross-section.
4606 IF(MSTP(171).EQ.1) THEN
4608 IF(MSTI(61).EQ.1) THEN
4612 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4616 C...Do not allow pileup events.
4619 C...Generate variables of hard scattering.
4623 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4628 IF(MSTI(61).EQ.1) THEN
4632 IF(MINT(51).EQ.2) RETURN
4635 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4636 C...Hard scattering (including low-pT):
4637 C...reconstruct kinematics and colour flow of hard scattering.
4642 IF(MINT(51).EQ.1) GOTO 100
4646 C...Decay of final state resonances.
4648 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4650 IF(MINT(51).EQ.1) GOTO 100
4653 C...Longitudinal boost of hard scattering.
4654 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4655 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4657 ELSEIF(ISUB.NE.99) THEN
4658 C...Diffractive and elastic scattering.
4662 C...DIS scattering (photon flux external).
4664 IF(MINT(51).EQ.1) GOTO 100
4667 C...Check that no odd resonance left undecayed.
4670 DO 120 I=MINT(84)+1,NFIX
4671 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4672 & K(I,2).NE.22) THEN
4674 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4676 IF(MINT(51).EQ.1) GOTO 100
4681 C...Boost hadronic subsystem to overall rest frame.
4682 C..(Only relevant when photon inside lepton beam.)
4683 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4685 C...Store event information and calculate Monte Carlo estimates of
4686 C...subprocess cross-sections.
4689 C...Transform to the desired coordinate frame.
4690 140 CALL PYFRAM(MSTP(124))
4694 C...Restore special flags for hard-process generation only.
4698 C...Trace colour tags; convert to LHA style labels.
4700 DO 150 I=MINT(84)+1,N
4704 DO 160 I=MINT(84)+1,N
4705 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4706 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4707 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4709 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4710 IDA=MOD(K(I,4),MSTU(5))
4711 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4712 & MCT(IMO,2).NE.0) THEN
4714 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4715 & MCT(IMO,1).NE.0) THEN
4717 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4718 & MCT(IDA,2).NE.0) THEN
4725 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4727 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4728 IDA=MOD(K(I,5),MSTU(5))
4729 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4730 & MCT(IMO,1).NE.0) THEN
4732 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4733 & MCT(IMO,2).NE.0) THEN
4735 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4736 & MCT(IDA,1).NE.0) THEN
4746 C...Put event in HEPEUP commonblock.
4754 IDUP(I)=K(I+MINT(84),2)
4759 ELSEIF(K(I+4,3).EQ.0) THEN
4765 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4768 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4769 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4770 ICOLUP(1,I)=MCT(I+MINT(84),1)
4771 ICOLUP(2,I)=MCT(I+MINT(84),2)
4773 PUP(J,I)=P(I+MINT(84),J)
4779 C...Optionally write out event to disk. Minimal size for time/spin fields.
4780 IF(MSTP(162).GT.0) THEN
4781 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4783 IF(VTIMUP(I).EQ.0D0) THEN
4784 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4785 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4788 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4789 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4794 C...Optional extra line with parton-density information.
4795 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4796 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4799 C...Error messages and other print formats.
4800 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4801 &1X,'Execution stopped.')
4802 5200 FORMAT(1P,2I6,4E14.6)
4803 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4804 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4805 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4810 C*********************************************************************
4813 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4814 C...processes, and optionally stores that information on file.
4818 C...Double precision and integer declarations.
4819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4820 IMPLICIT INTEGER(I-N)
4823 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4824 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4825 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4826 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4827 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4829 C...User process initialization commonblock.
4831 PARAMETER (MAXPUP=100)
4832 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4833 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4834 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4835 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4839 C...Store info on incoming beams.
4849 C...Event weighting strategy.
4852 C...Info on individual processes.
4855 IF(MSUB(ISUB).EQ.1) THEN
4857 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4858 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4864 C...Write info to file.
4865 IF(MSTP(161).GT.0) THEN
4866 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4867 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4869 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4874 C...Formats for printout.
4875 5100 FORMAT(1P,2I8,2E14.6,6I6)
4876 5200 FORMAT(1P,3E14.6,I6)
4882 C*********************************************************************
4884 C...Combine the two old-style Pythia initialization and event files
4885 C...into a single Les Houches Event File.
4889 C...Double precision and integer declarations.
4890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4891 IMPLICIT INTEGER(I-N)
4893 C...PYTHIA commonblock: only used to provide read/write units and version.
4894 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4897 C...User process initialization commonblock.
4899 PARAMETER (MAXPUP=100)
4900 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4901 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4902 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4903 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4907 C...User process event common block.
4909 PARAMETER (MAXNUP=500)
4910 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4911 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4912 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4913 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4914 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4917 C...Lines to read in assumed never longer than 200 characters.
4918 PARAMETER (MAXLEN=200)
4919 CHARACTER*(MAXLEN) STRING
4921 C...Format for reading lines.
4924 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4926 C...Rewind initialization and event files.
4930 C...Write header info.
4931 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4932 WRITE(MSTP(163),'(A)') '<!--'
4933 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4934 &MSTP(181),'.',MSTP(182)
4935 WRITE(MSTP(163),'(A)') '-->'
4937 C...Read first line of initialization info and get number of processes.
4938 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4939 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4940 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4942 C...Copy initialization lines, omitting trailing blanks.
4943 C...Embed in <init> ... </init> block.
4944 WRITE(MSTP(163),'(A)') '<init>'
4946 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4949 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4950 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4952 WRITE(MSTP(163),'(A)') '</init>'
4954 C...Begin event loop. Read first line of event info or already done.
4955 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4958 C...Look at first line to know number of particles in event.
4959 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4961 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4962 WRITE(MSTP(163),'(A)') '<event>'
4964 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4967 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4968 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4971 C...Copy trailing comment lines - with a # in the first column - as is.
4972 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4973 IF(STRING(1:1).EQ.'#') THEN
4976 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4977 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4981 C..End the <event> block. Loop back to look for next event.
4982 WRITE(MSTP(163),'(A)') '</event>'
4985 C...Successfully reached end of event loop: write closing tag
4986 C...and remove temporary intermediate files (unless asked not to).
4987 300 WRITE(MSTP(163),'(A)') '</event>'
4988 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4989 IF(MSTP(164).EQ.1) RETURN
4990 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4991 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4995 400 WRITE(*,*) ' PYLHEF file joining failed!'
5000 C*********************************************************************
5003 C...Calculates full and effective widths of gauge bosons, stores
5004 C...masses and widths, rescales coefficients to be used for
5005 C...resonance production generation.
5009 C...Double precision and integer declarations.
5010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5011 IMPLICIT INTEGER(I-N)
5012 INTEGER PYK,PYCHGE,PYCOMP
5013 C...Parameter statement to help give large particle numbers.
5014 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5015 &KEXCIT=4000000,KDIMEN=5000000)
5017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5019 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5020 COMMON/PYDAT4/CHAF(500,2)
5022 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5023 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5024 COMMON/PYINT1/MINT(400),VINT(400)
5025 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5026 COMMON/PYINT4/MWID(500),WIDS(500,5)
5027 COMMON/PYINT6/PROC(0:500)
5029 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5030 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5031 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5032 C...Local arrays and data.
5033 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5034 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5036 C...Born level couplings in MSSM Higgs doublet sector.
5039 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5041 IF(MSTP(4).EQ.2) THEN
5043 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5047 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5048 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5050 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5051 WRITE(MSTU(11),5000)
5054 PMAS(35,1)=SQRT(SQMHP)
5055 PMAS(36,1)=SQRT(SQMA)
5056 PMAS(37,1)=SQRT(SQMHC)
5057 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5062 PARU(161)=-SIN(ALSU)/COS(BESU)
5063 PARU(162)=COS(ALSU)/SIN(BESU)
5065 PARU(164)=SIN(BESU-ALSU)
5067 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5068 PARU(171)=COS(ALSU)/COS(BESU)
5069 PARU(172)=SIN(ALSU)/SIN(BESU)
5071 PARU(174)=COS(BESU-ALSU)
5073 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5075 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5076 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5082 PARU(186)=COS(BESU-ALSU)
5083 PARU(187)=SIN(BESU-ALSU)
5087 PARU(195)=COS(BESU-ALSU)
5090 C...Reset effective widths of gauge bosons.
5097 C...Order resonances by increasing mass (except Z0 and W+/-).
5101 IF(KF.EQ.0) GOTO 140
5102 IF(MWID(KC).EQ.0) GOTO 140
5103 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5104 IF(MSTP(1).LE.3) GOTO 140
5106 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5107 IF(IMSS(1).LE.0) GOTO 140
5111 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5112 DO 120 I1=NRES-1,1,-1
5113 IF(PMRES.GE.PMORD(I1)) GOTO 130
5114 KCORD(I1+1)=KCORD(I1)
5115 PMORD(I1+1)=PMORD(I1)
5121 C...Loop over possible resonances.
5126 C...Check that no fourth generation channels on by mistake.
5127 IF(MSTP(1).LE.3) THEN
5128 DO 150 J=1,MDCY(KC,3)
5130 KFA1=IABS(KFDP(IDC,1))
5131 KFA2=IABS(KFDP(IDC,2))
5132 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5133 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5138 C...Check that no supersymmetric channels on by mistake.
5139 IF(IMSS(1).LE.0) THEN
5140 DO 160 J=1,MDCY(KC,3)
5142 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5143 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5144 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5149 C...Find mass and evaluate width.
5151 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5152 IF(MWID(KC).EQ.3) MINT(63)=1
5153 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5156 C...Evaluate suppression factors due to non-simulated channels.
5157 IF(KCHG(KC,3).EQ.0) THEN
5159 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5160 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5161 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5162 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5163 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5168 IF(MWID(KC).EQ.3) MINT(63)=1
5169 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5172 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5173 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5174 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5175 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5176 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5177 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5178 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5179 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5180 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5181 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5182 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5183 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5184 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5187 C...Set resonance widths and branching ratios;
5188 C...also on/off switch for decays.
5189 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5191 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5192 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5193 DO 170 J=1,MDCY(KC,3)
5196 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5201 C...Flavours of leptoquark: redefine charge and name.
5202 KFLQQ=KFDP(MDCY(42,2),1)
5203 KFLQL=KFDP(MDCY(42,2),2)
5204 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5205 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5207 IF(IABS(KFLQL).EQ.13) LL=2
5208 IF(IABS(KFLQL).EQ.15) LL=3
5209 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5210 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5211 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5213 C...Special cases in treatment of gamma*/Z0: redefine process name.
5214 IF(MSTP(43).EQ.1) THEN
5215 PROC(1)='f + fbar -> gamma*'
5216 PROC(15)='f + fbar -> g + gamma*'
5217 PROC(19)='f + fbar -> gamma + gamma*'
5218 PROC(30)='f + g -> f + gamma*'
5219 PROC(35)='f + gamma -> f + gamma*'
5220 ELSEIF(MSTP(43).EQ.2) THEN
5221 PROC(1)='f + fbar -> Z0'
5222 PROC(15)='f + fbar -> g + Z0'
5223 PROC(19)='f + fbar -> gamma + Z0'
5224 PROC(30)='f + g -> f + Z0'
5225 PROC(35)='f + gamma -> f + Z0'
5226 ELSEIF(MSTP(43).EQ.3) THEN
5227 PROC(1)='f + fbar -> gamma*/Z0'
5228 PROC(15)='f + fbar -> g + gamma*/Z0'
5229 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5230 PROC(30)='f + g -> f + gamma*/Z0'
5231 PROC(35)='f + gamma -> f + gamma*/Z0'
5234 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5235 IF(MSTP(44).EQ.1) THEN
5236 PROC(141)='f + fbar -> gamma*'
5237 ELSEIF(MSTP(44).EQ.2) THEN
5238 PROC(141)='f + fbar -> Z0'
5239 ELSEIF(MSTP(44).EQ.3) THEN
5240 PROC(141)='f + fbar -> Z''0'
5241 ELSEIF(MSTP(44).EQ.4) THEN
5242 PROC(141)='f + fbar -> gamma*/Z0'
5243 ELSEIF(MSTP(44).EQ.5) THEN
5244 PROC(141)='f + fbar -> gamma*/Z''0'
5245 ELSEIF(MSTP(44).EQ.6) THEN
5246 PROC(141)='f + fbar -> Z0/Z''0'
5247 ELSEIF(MSTP(44).EQ.7) THEN
5248 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5251 C...Special cases in treatment of WW -> WW: redefine process name.
5252 IF(MSTP(45).EQ.1) THEN
5253 PROC(77)='W+ + W+ -> W+ + W+'
5254 ELSEIF(MSTP(45).EQ.2) THEN
5255 PROC(77)='W+ + W- -> W+ + W-'
5256 ELSEIF(MSTP(45).EQ.3) THEN
5257 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5260 C...Format for error information.
5261 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5262 &'combination'/1X,'Execution stopped!')
5267 C*********************************************************************
5270 C...Identifies the two incoming particles and the choice of frame.
5272 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5274 C...Double precision and integer declarations.
5275 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5276 IMPLICIT INTEGER(I-N)
5277 INTEGER PYK,PYCHGE,PYCOMP
5279 C...User process initialization commonblock.
5281 PARAMETER (MAXPUP=100)
5282 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5283 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5284 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5285 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5290 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5293 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5294 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5295 COMMON/PYINT1/MINT(400),VINT(400)
5296 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5298 C...Local arrays, character variables and data.
5299 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5300 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5301 DIMENSION LEN(3),KCDE(39),PM(2)
5302 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5303 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5304 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5305 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5306 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5307 &'nu_taubar ','pi+ ','pi- ','n0 ',
5308 &'nbar0 ','p+ ','pbar- ','gamma ',
5309 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5310 &'xi- ','xi0 ','omega- ','pi0 ',
5311 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5312 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5313 &'k+ ','k- ','ks0 ','kl0 '/
5314 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5315 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5316 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5318 C...Store initial energy. Default frame.
5322 C...Special user process initialization; convert to normal input.
5323 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5325 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5326 CALL PYNAME(IDBMUP(1),CHNAME)
5328 CALL PYNAME(IDBMUP(2),CHNAME)
5332 C...Convert character variables to lowercase and find their length.
5339 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5341 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5347 C...Fix up bar, underscore and charge in particle name (if needed).
5349 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5351 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5354 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5356 CHIDNT(I)='nu_'//CHTEMP(3:7)
5357 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5358 CHIDNT(I)(1:3)='n0 '
5359 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5360 CHIDNT(I)(1:5)='nbar0'
5361 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5362 CHIDNT(I)(1:3)='p+ '
5363 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5364 & CHIDNT(I)(1:2).EQ.'p-') THEN
5365 CHIDNT(I)(1:5)='pbar-'
5366 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5368 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5369 CHIDNT(I)(1:7)='reggeon'
5370 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5371 CHIDNT(I)(1:7)='pomeron'
5375 C...Identify free initialization.
5376 IF(CHCOM(1)(1:2).EQ.'no') THEN
5381 C...Identify incoming beam and target particles.
5384 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5386 PM(I)=PYMASS(MINT(10+I))
5389 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5390 CHTEMP=CHIDNT(I+1)(7:12)//' '
5392 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5394 PM(I)=PYMASS(MINT(140+I))
5398 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5399 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5400 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5402 C...Identify choice of frame and input energies.
5405 C...Events defined in the CM frame.
5406 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5409 IF(MSTP(122).GE.1) THEN
5410 IF(CHCOM(2)(1:1).NE.'e') THEN
5411 LOFFS=(31-(LEN(2)+LEN(3)))/2
5412 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5413 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5416 LOFFS=(30-(LEN(2)+LEN(3)))/2
5417 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5418 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5421 WRITE(MSTU(11),5200) CHINIT
5422 WRITE(MSTU(11),5300) WIN
5425 C...Events defined in fixed target frame.
5426 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5428 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5429 IF(MSTP(122).GE.1) THEN
5430 LOFFS=(29-(LEN(2)+LEN(3)))/2
5431 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5432 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5433 & ' fixed target'//' '
5434 WRITE(MSTU(11),5200) CHINIT
5435 WRITE(MSTU(11),5400) WIN
5436 WRITE(MSTU(11),5500) SQRT(S)
5439 C...Frame defined by user three-vectors.
5440 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5444 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5445 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5446 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5447 & (P(1,3)+P(2,3))**2
5448 IF(MSTP(122).GE.1) THEN
5449 LOFFS=(22-(LEN(2)+LEN(3)))/2
5450 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5451 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5452 & ' user configuration'//' '
5453 WRITE(MSTU(11),5200) CHINIT
5454 WRITE(MSTU(11),5600)
5455 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5456 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5457 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5460 C...Frame defined by user four-vectors.
5461 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5463 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5464 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5465 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5466 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5467 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5468 & (P(1,3)+P(2,3))**2
5469 IF(MSTP(122).GE.1) THEN
5470 LOFFS=(22-(LEN(2)+LEN(3)))/2
5471 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5472 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5473 & ' user configuration'//' '
5474 WRITE(MSTU(11),5200) CHINIT
5475 WRITE(MSTU(11),5600)
5476 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5477 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5478 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5481 C...Frame defined by user five-vectors.
5482 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5484 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5485 & (P(1,3)+P(2,3))**2
5486 IF(MSTP(122).GE.1) THEN
5487 LOFFS=(22-(LEN(2)+LEN(3)))/2
5488 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5489 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5490 & ' user configuration'//' '
5491 WRITE(MSTU(11),5200) CHINIT
5492 WRITE(MSTU(11),5600)
5493 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5494 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5495 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5498 C...Frame defined by HEPRUP common block.
5499 ELSEIF(MINT(111).GE.11) THEN
5500 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5501 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5502 IF(MSTP(122).GE.1) THEN
5503 LOFFS=(22-(LEN(2)+LEN(3)))/2
5504 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5505 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5506 & ' user configuration'//' '
5507 WRITE(MSTU(11),5200) CHINIT
5508 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5509 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5512 C...Unknown frame. Error for too low CM energy.
5514 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5517 IF(S.LT.PARP(2)**2) THEN
5518 WRITE(MSTU(11),5900) SQRT(S)
5522 C...Formats for initialization and error information.
5523 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5524 &1X,'Execution stopped!')
5525 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5526 &1X,'Execution stopped!')
5527 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5528 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5529 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5530 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5531 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5532 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5533 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5534 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5535 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5536 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5537 &1X,'Execution stopped!')
5538 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5539 &'generation.'/1X,'Execution stopped!')
5540 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5541 &'GeV beam energies',13X,'I')
5546 C*********************************************************************
5549 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5551 SUBROUTINE PYINKI(MODKI)
5553 C...Double precision and integer declarations.
5554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5555 IMPLICIT INTEGER(I-N)
5556 INTEGER PYK,PYCHGE,PYCOMP
5558 C...User process initialization commonblock.
5560 PARAMETER (MAXPUP=100)
5561 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5562 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5563 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5564 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5572 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5573 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5574 COMMON/PYINT1/MINT(400),VINT(400)
5575 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5577 C...Set initial flavour state.
5582 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5585 C...Reset boost. Do kinematics for various cases.
5590 C...Set up kinematics for events defined in CM frame.
5591 IF(MINT(111).EQ.1) THEN
5593 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5597 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5598 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5603 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5606 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5607 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5609 C...Set up kinematics for fixed target events.
5610 ELSEIF(MINT(111).EQ.2) THEN
5612 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5615 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5616 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5622 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5625 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5626 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5627 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5629 C...Set up kinematics for events in user-defined frame.
5630 ELSEIF(MINT(111).EQ.3) THEN
5633 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5634 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5635 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5636 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5638 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5640 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5641 VINT(7)=PYANGL(P(1,1),P(1,2))
5642 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5643 VINT(6)=PYANGL(P(1,3),P(1,1))
5644 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5645 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5647 C...Set up kinematics for events with user-defined four-vectors.
5648 ELSEIF(MINT(111).EQ.4) THEN
5649 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5650 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5651 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5652 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5654 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5656 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5657 VINT(7)=PYANGL(P(1,1),P(1,2))
5658 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5659 VINT(6)=PYANGL(P(1,3),P(1,1))
5660 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5661 S=(P(1,4)+P(2,4))**2
5663 C...Set up kinematics for events with user-defined five-vectors.
5664 ELSEIF(MINT(111).EQ.5) THEN
5666 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5668 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5669 VINT(7)=PYANGL(P(1,1),P(1,2))
5670 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5671 VINT(6)=PYANGL(P(1,3),P(1,1))
5672 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5673 S=(P(1,4)+P(2,4))**2
5675 C...Set up kinematics for events with external user processes.
5676 ELSEIF(MINT(111).GE.11) THEN
5679 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5680 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5685 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5686 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5689 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5690 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5691 S=(P(1,4)+P(2,4))**2
5694 C...Return or error for too low CM energy.
5695 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5696 IF(MSTP(172).LE.1) THEN
5698 & '(PYINKI:) too low invariant mass in this event')
5705 C...Save information on incoming particles.
5708 IF(MINT(111).GE.4) THEN
5709 IF(MINT(141).EQ.0) THEN
5711 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5715 IF(MINT(142).EQ.0) THEN
5717 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5723 IF(MODKI.EQ.0) VINT(289)=S
5731 C...Store pT cut-off and related constants to be used in generation.
5732 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5733 IF(MSTP(82).LE.1) THEN
5734 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5736 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5738 VINT(149)=4D0*PTMN**2/S
5744 C*********************************************************************
5747 C...Selects partonic subprocesses to be included in the simulation.
5751 C...Double precision and integer declarations.
5752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5753 IMPLICIT INTEGER(I-N)
5754 INTEGER PYK,PYCHGE,PYCOMP
5756 C...User process initialization commonblock.
5758 PARAMETER (MAXPUP=100)
5759 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5760 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5761 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5762 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5766 C...Commonblocks and character variables.
5767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5768 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5769 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5770 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5771 COMMON/PYINT1/MINT(400),VINT(400)
5772 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5773 COMMON/PYINT6/PROC(0:500)
5775 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5779 C...Reset processes to be included.
5786 C...Set running pTmin scale.
5787 IF(MSTP(82).LE.1) THEN
5788 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5790 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5793 C...Begin by assuming incoming photon to enter subprocess.
5794 IF(MINT(11).EQ.22) MINT(15)=22
5795 IF(MINT(12).EQ.22) MINT(16)=22
5797 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5798 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5800 MINT(123)=MINT(122)+1
5802 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5804 C...Here also set a few parameters otherwise normally not touched.
5805 ELSEIF(MINT(121).GT.1) THEN
5807 C...Parton distributions dampened at small Q2; go to low energies,
5808 C...alpha_s <1; no minimum pT cut-off a priori.
5809 IF(MSTP(18).EQ.2) THEN
5817 C...Define pT cut-off parameters and whether run involves low-pT.
5821 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5823 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5824 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5826 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5827 IF(MSEL.EQ.2) IPTL=1
5829 C...Set up for p/gamma * gamma; real or virtual photons.
5830 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5831 & MSTP(14).EQ.30)) THEN
5833 C...Set up for p/VMD * VMD.
5834 IF(MINT(122).EQ.1) THEN
5842 IF(IPTL.EQ.1) MSUB(95)=1
5849 IF(IPTL.EQ.1) CKIN(3)=0D0
5851 C...Set up for p/VMD * direct gamma.
5852 ELSEIF(MINT(122).EQ.2) THEN
5854 IF(MINT(121).EQ.6) MINT(123)=5
5859 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5861 C...Set up for p/VMD * anomalous gamma.
5862 ELSEIF(MINT(122).EQ.3) THEN
5864 IF(MINT(121).EQ.6) MINT(123)=7
5871 IF(IPTL.EQ.1) MSUB(95)=1
5878 IF(IPTL.EQ.1) CKIN(3)=0D0
5880 C...Set up for DIS * p.
5881 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5882 & IABS(MINT(12)).GT.100)) THEN
5884 IF(IPTL.EQ.1) MSUB(99)=1
5886 C...Set up for direct * direct gamma (switch off leptons).
5887 ELSEIF(MINT(122).EQ.4) THEN
5893 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5894 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5896 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5898 C...Set up for direct * anomalous gamma.
5899 ELSEIF(MINT(122).EQ.5) THEN
5905 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5907 C...Set up for anomalous * anomalous gamma.
5908 ELSEIF(MINT(122).EQ.6) THEN
5916 IF(IPTL.EQ.1) MSUB(95)=1
5923 IF(IPTL.EQ.1) CKIN(3)=0D0
5926 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5927 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5929 C...Set up for direct * direct gamma (switch off leptons).
5930 IF(MINT(122).EQ.1) THEN
5936 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5937 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5939 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5941 C...Set up for direct * VMD and VMD * direct gamma.
5942 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5948 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5950 C...Set up for direct * anomalous and anomalous * direct gamma.
5951 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5957 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5959 C...Set up for VMD*VMD.
5960 ELSEIF(MINT(122).EQ.5) THEN
5968 IF(IPTL.EQ.1) MSUB(95)=1
5975 IF(IPTL.EQ.1) CKIN(3)=0D0
5977 C...Set up for VMD * anomalous and anomalous * VMD gamma.
5978 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5986 IF(IPTL.EQ.1) MSUB(95)=1
5993 IF(IPTL.EQ.1) CKIN(3)=0D0
5995 C...Set up for anomalous * anomalous gamma.
5996 ELSEIF(MINT(122).EQ.9) THEN
6004 IF(IPTL.EQ.1) MSUB(95)=1
6011 IF(IPTL.EQ.1) CKIN(3)=0D0
6013 C...Set up for DIS * VMD and VMD * DIS gamma.
6014 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6016 IF(IPTL.EQ.1) MSUB(99)=1
6018 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6019 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6021 IF(IPTL.EQ.1) MSUB(99)=1
6024 C...Set up for gamma* * p; virtual photons = dir, res.
6025 ELSEIF(MINT(121).EQ.2) THEN
6027 C...Set up for direct * p.
6028 IF(MINT(122).EQ.1) THEN
6034 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6036 C...Set up for resolved * p.
6037 ELSEIF(MINT(122).EQ.2) THEN
6045 IF(IPTL.EQ.1) MSUB(95)=1
6052 IF(IPTL.EQ.1) CKIN(3)=0D0
6055 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6056 ELSEIF(MINT(121).EQ.4) THEN
6058 C...Set up for direct * direct gamma (switch off leptons).
6059 IF(MINT(122).EQ.1) THEN
6065 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6066 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6068 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6070 C...Set up for direct * resolved and resolved * direct gamma.
6071 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6077 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6079 C...Set up for resolved * resolved gamma.
6080 ELSEIF(MINT(122).EQ.4) THEN
6088 IF(IPTL.EQ.1) MSUB(95)=1
6095 IF(IPTL.EQ.1) CKIN(3)=0D0
6098 C...End of special set up for gamma-p and gamma-gamma.
6103 C...Flavour information for individual beams.
6106 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6107 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6108 MINT(44+I)=MINT(40+I)
6109 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6110 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6113 C...If two real gammas, whereof one direct, pick the first.
6114 C...For two virtual photons, keep requested order.
6115 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6116 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6119 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6120 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6123 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6124 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6127 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6128 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6131 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6132 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6135 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6138 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6142 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6143 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6144 IF(MINT(11).EQ.22) THEN
6152 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6153 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6156 C...Flavour information on combination of incoming particles.
6157 MINT(43)=2*MINT(41)+MINT(42)-2
6159 IF(MINT(123).LE.0) THEN
6160 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6161 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6162 ELSEIF(MINT(123).LE.3) THEN
6163 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6164 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6165 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6169 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6170 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6171 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6172 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6174 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6177 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6178 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6180 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6182 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6183 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6184 & MINT(122).EQ.10) MINT(108)=2
6185 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6186 & MINT(122).EQ.11) MINT(108)=3
6187 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6188 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6189 IF(MINT(122).GE.3) MINT(107)=1
6190 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6191 ELSEIF(MINT(121).EQ.2) THEN
6192 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6193 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6195 IF(MINT(11).EQ.22) THEN
6197 IF(MINT(123).GE.4) MINT(107)=0
6198 IF(MINT(123).EQ.7) MINT(107)=2
6199 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6200 IF(MSTP(14).EQ.28) MINT(107)=2
6201 IF(MSTP(14).EQ.29) MINT(107)=3
6202 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6205 IF(MINT(12).EQ.22) THEN
6207 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6208 IF(MINT(123).EQ.7) MINT(108)=3
6209 IF(MSTP(14).EQ.26) MINT(108)=2
6210 IF(MSTP(14).EQ.27) MINT(108)=3
6211 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6212 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6215 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6216 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6222 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6223 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6225 C...Select default processes according to incoming beams
6226 C...(already done for gamma-p and gamma-gamma with
6227 C...MSTP(14) = 10, 20, 25 or 30).
6228 IF(MINT(121).GT.1) THEN
6229 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6231 IF(MINT(43).EQ.1) THEN
6232 C...Lepton + lepton -> gamma/Z0 or W.
6233 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6234 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6236 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6237 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6238 C...Unresolved photon + lepton: Compton scattering.
6242 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6243 & .OR.MINT(12).EQ.22)) THEN
6244 C...DIS as pure gamma* + f -> f process.
6247 ELSEIF(MINT(43).LE.3) THEN
6248 C...Lepton + hadron: deep inelastic scattering.
6251 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6252 & MINT(12).EQ.22) THEN
6253 C...Two unresolved photons: fermion pair production,
6254 C...exclude lepton pairs.
6258 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6259 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6262 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6263 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6264 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6266 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6267 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6268 & MINT(12).EQ.22)) THEN
6269 C...Unresolved photon + hadron: photon-parton scattering.
6274 ELSEIF(MSEL.EQ.1) THEN
6275 C...High-pT QCD processes:
6284 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6285 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6288 C...All QCD processes:
6302 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6303 C...Heavy quark production.
6307 DO 180 J=1,MIN(8,MDCY(21,3))
6308 MDME(MDCY(21,2)+J-1,1)=0
6310 MDME(MDCY(21,2)+MSEL-1,1)=1
6312 DO 190 J=1,MIN(12,MDCY(22,3))
6313 MDME(MDCY(22,2)+J-1,1)=0
6315 MDME(MDCY(22,2)+MSEL-1,1)=1
6317 ELSEIF(MSEL.EQ.10) THEN
6318 C...Prompt photon production:
6323 ELSEIF(MSEL.EQ.11) THEN
6324 C...Z0/gamma* production:
6327 ELSEIF(MSEL.EQ.12) THEN
6328 C...W+/- production:
6331 ELSEIF(MSEL.EQ.13) THEN
6336 ELSEIF(MSEL.EQ.14) THEN
6341 ELSEIF(MSEL.EQ.15) THEN
6342 C...Z0 & W+/- pair production:
6349 ELSEIF(MSEL.EQ.16) THEN
6357 ELSEIF(MSEL.EQ.17) THEN
6358 C...h0 & Z0 or W+/- pair production:
6362 ELSEIF(MSEL.EQ.18) THEN
6363 C...h0 production; interesting processes in e+e-.
6369 ELSEIF(MSEL.EQ.19) THEN
6370 C...h0, H0 and A0 production; interesting processes in e+e-.
6384 ELSEIF(MSEL.EQ.21) THEN
6388 ELSEIF(MSEL.EQ.22) THEN
6389 C...W'+/- production:
6392 ELSEIF(MSEL.EQ.23) THEN
6393 C...H+/- production:
6396 ELSEIF(MSEL.EQ.24) THEN
6400 ELSEIF(MSEL.EQ.25) THEN
6401 C...LQ (leptoquark) production.
6407 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6408 C...Production of one heavy quark (W exchange):
6410 DO 200 J=1,MIN(8,MDCY(21,3))
6411 MDME(MDCY(21,2)+J-1,1)=0
6413 MDME(MDCY(21,2)+MSEL-31,1)=1
6415 CMRENNA++Define SUSY alternatives.
6416 ELSEIF(MSEL.EQ.39) THEN
6417 C...Turn on all SUSY processes.
6418 IF(MINT(43).EQ.4) THEN
6419 C...Hadron-hadron processes.
6421 IF(ISET(I).GE.0) MSUB(I)=1
6423 ELSEIF(MINT(43).EQ.1) THEN
6424 C...Lepton-lepton processes: QED production of squarks.
6441 ELSEIF(MSEL.EQ.40) THEN
6442 C...Gluinos and squarks.
6443 IF(MINT(43).EQ.4) THEN
6455 ELSEIF(MINT(43).EQ.1) THEN
6460 ELSEIF(MSEL.EQ.41) THEN
6461 C...Stop production.
6465 IF(MINT(43).EQ.4) THEN
6470 ELSEIF(MSEL.EQ.42) THEN
6471 C...Slepton production.
6475 IF(MINT(43).NE.4) THEN
6481 ELSEIF(MSEL.EQ.43) THEN
6482 C...Neutralino/Chargino + Gluino/Squark.
6483 IF(MINT(43).EQ.4) THEN
6493 ELSEIF(MSEL.EQ.44) THEN
6494 C...Neutralino/Chargino pair production.
6495 IF(MINT(43).EQ.4) THEN
6499 ELSEIF(MINT(43).EQ.1) THEN
6505 ELSEIF(MSEL.EQ.45) THEN
6506 C...Sbottom production.
6509 IF(MINT(43).EQ.4) THEN
6515 ELSEIF(MSEL.EQ.50) THEN
6516 C...Pair production of technipions and gauge bosons.
6520 IF(MINT(43).EQ.4) THEN
6526 ELSEIF(MSEL.EQ.51) THEN
6527 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6532 ELSEIF(MSEL.EQ.61) THEN
6533 C...Charmonium production in colour octet model, with recoiling parton.
6538 ELSEIF(MSEL.EQ.62) THEN
6539 C...Bottomonium production in colour octet model, with recoiling parton.
6544 ELSEIF(MSEL.EQ.63) THEN
6545 C...Charmonium and bottomonium production in colour octet model.
6552 C...Find heaviest new quark flavour allowed in processes 81-84.
6554 DO 350 I=1,MIN(8,MDCY(21,3))
6556 IF(MDME(IDC,1).LE.0) GOTO 350
6559 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6570 C...Find heaviest new fermion flavour allowed in process 85.
6572 DO 360 I=1,MIN(12,MDCY(22,3))
6574 IF(MDME(IDC,1).LE.0) GOTO 360
6577 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6578 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6583 C...Import relevant information on external user processes.
6584 IF(MINT(111).GE.11) THEN
6587 C...Find next empty PYTHIA process number slot and enable it.
6589 IF(IPYPR.GT.500) CALL PYERRM(26,
6590 & '(PYINPR.) no more empty slots for user processes')
6591 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6592 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6594 C...Overwrite KFPR with references back to process number and ID.
6596 KFPR(IPYPR,2)=LPRUP(IUP)
6598 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6601 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6603 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6604 C...Switch on process.
6612 C*********************************************************************
6615 C...Parametrizes total, elastic and diffractive cross-sections
6616 C...for different energies and beams. Donnachie-Landshoff for
6617 C...total and Schuler-Sjostrand for elastic and diffractive.
6618 C...Process code IPROC:
6625 C...= 7 : J/psi + p;
6626 C...= 11 : rho + rho;
6627 C...= 12 : rho + phi;
6628 C...= 13 : rho + J/psi;
6629 C...= 14 : phi + phi;
6630 C...= 15 : phi + J/psi;
6631 C...= 16 : J/psi + J/psi;
6632 C...= 21 : gamma + p (DL);
6633 C...= 22 : gamma + p (VDM).
6634 C...= 23 : gamma + pi (DL);
6635 C...= 24 : gamma + pi (VDM);
6636 C...= 25 : gamma + gamma (DL);
6637 C...= 26 : gamma + gamma (VDM).
6641 C...Double precision and integer declarations.
6642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6643 IMPLICIT INTEGER(I-N)
6644 INTEGER PYK,PYCHGE,PYCOMP
6646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6647 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6648 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6649 COMMON/PYINT1/MINT(400),VINT(400)
6650 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6651 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6652 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6654 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6655 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6656 &CEFFD(10,9),SIGTMP(6,0:5)
6658 C...Common constants.
6659 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6660 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6663 C...Number of multiple processes to be evaluated (= 0 : undefined).
6664 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6665 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6666 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6667 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6668 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6670 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6671 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6672 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6674 C...Beam and target hadron class:
6675 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6676 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6677 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6678 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6679 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6680 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6681 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6683 C...Fitting constants used in parametrizations of diffractive results.
6684 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6685 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6686 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6687 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6688 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6689 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6690 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6691 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6692 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6693 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6694 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6695 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6696 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6697 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6698 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6699 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6700 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6701 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6702 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6703 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6704 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6705 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6706 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6707 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6708 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6709 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6710 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6711 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6712 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6714 C...Parameters. Combinations of the energy.
6723 C...Ratio of gamma/pi (for rescaling in parton distributions).
6724 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6725 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6727 IF(MINT(50).NE.1) RETURN
6729 C...Order flavours of incoming particles: KF1 < KF2.
6730 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6739 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6741 C...Find process number (for lookup tables).
6742 IF(KF1.GT.1000) THEN
6744 IF(ISGN12.LT.0) IPROC=2
6745 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6747 IF(ISGN12.LT.0) IPROC=4
6748 IF(KF1.EQ.111) IPROC=5
6749 ELSEIF(KF1.GT.100) THEN
6751 ELSEIF(KF2.GT.1000) THEN
6753 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6754 ELSEIF(KF2.GT.100) THEN
6756 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6759 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6762 C... Number of multiple processes to be stored; beam/target side.
6768 ELSEIF(NPR.EQ.6) THEN
6773 IF(MINT(101).EQ.4) N1=4
6775 IF(MINT(102).EQ.4) N2=4
6777 C...Do not do any more for user-set or undefined cross-sections.
6778 IF(MSTP(31).LE.0) RETURN
6779 IF(NPR.EQ.0) CALL PYERRM(26,
6780 &'(PYXTOT:) cross section for this process not yet implemented')
6782 C...Parameters. Combinations of the energy.
6791 C...Loop over multiple processes (for VDM).
6795 ELSEIF(NPR.EQ.3) THEN
6797 IF(KF2.LT.1000) IPR=I+10
6798 ELSEIF(NPR.EQ.6) THEN
6802 C...Evaluate hadron species, mass, slope contribution and fit number.
6812 C...Skip if energy too low relative to masses.
6816 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6818 C...Total cross-section. Elastic slope parameter and cross-section.
6819 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6820 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6821 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6823 C...Diffractive scattering A + B -> X + B.
6826 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6827 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6828 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6829 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6830 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6831 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6832 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6834 C...Diffractive scattering A + B -> A + X.
6837 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6838 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6839 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6840 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6841 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6842 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6843 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6845 C...Order single diffractive correctly.
6848 SIGTMP(I,2)=SIGTMP(I,3)
6852 C...Double diffractive scattering A + B -> X1 + X2.
6853 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6854 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6855 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6856 IF(YEFF.LE.0) SUM1=0D0
6857 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6858 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6859 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6860 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6862 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6863 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6864 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6866 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6867 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6868 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6869 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6870 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6872 C...Non-diffractive by unitarity.
6873 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6877 C...Put temporary results in output array: only one process.
6878 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6880 SIGT(0,0,J)=SIGTMP(1,J)
6883 C...Beam multiple processes.
6884 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6885 IF(MINT(107).EQ.2) THEN
6886 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6888 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6889 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6891 IF(MSTP(20).GT.0) THEN
6892 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6895 IF(MINT(107).EQ.2) THEN
6896 CONV=(AEM/PARP(160+I))*VINT(317)
6897 ELSEIF(VINT(154).GT.PARP(15)) THEN
6898 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6899 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6905 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6909 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6912 C...Target multiple processes.
6913 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6914 IF(MINT(108).EQ.2) THEN
6915 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6917 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6918 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6920 IF(MSTP(20).GT.0) THEN
6921 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6924 IF(MINT(108).EQ.2) THEN
6925 CONV=(AEM/PARP(160+I))*VINT(317)
6926 ELSEIF(VINT(154).GT.PARP(15)) THEN
6927 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6928 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6934 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6938 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6941 C...Both beam and target multiple processes.
6943 IF(MINT(107).EQ.2) THEN
6944 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6946 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6947 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6949 IF(MINT(108).EQ.2) THEN
6950 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6952 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6953 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6955 IF(MSTP(20).GT.0) THEN
6956 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6957 & VINT(308)))**MSTP(20)
6961 IF(MINT(107).EQ.2) THEN
6962 CONV=(AEM/PARP(160+I1))*VINT(317)
6963 ELSEIF(VINT(154).GT.PARP(15)) THEN
6964 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6965 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6969 IF(MINT(108).EQ.2) THEN
6970 CONV=CONV*(AEM/PARP(160+I2))
6971 ELSEIF(VINT(154).GT.PARP(15)) THEN
6972 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6973 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6979 ELSEIF(I2.LE.2) THEN
6981 ELSEIF(I1.EQ.I2) THEN
6988 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6989 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6995 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
6996 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
6998 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7002 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7003 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7004 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7008 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7017 C*********************************************************************
7020 C...Finds optimal set of coefficients for kinematical variable selection
7021 C...and the maximum of the part of the differential cross-section used
7022 C...in the event weighting.
7026 C...Double precision and integer declarations.
7027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7028 IMPLICIT INTEGER(I-N)
7029 INTEGER PYK,PYCHGE,PYCOMP
7030 C...Parameter statement to help give large particle numbers.
7031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7032 &KEXCIT=4000000,KDIMEN=5000000)
7034 C...User process initialization commonblock.
7036 PARAMETER (MAXPUP=100)
7037 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7038 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7039 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7040 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7046 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7047 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7048 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7049 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7050 COMMON/PYINT1/MINT(400),VINT(400)
7051 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7052 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7053 COMMON/PYINT4/MWID(500),WIDS(500,5)
7054 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7055 COMMON/PYINT6/PROC(0:500)
7057 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7058 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7059 COMMON/PYTCCO/COEFX(194:380,2)
7060 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7061 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7062 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7064 C...Local arrays, character variables and data.
7067 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7068 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7069 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7070 DATA CVAR/'tau ','tau''','y* ','cth '/
7073 C...Initial values and loop over subprocesses.
7083 C...Find maximum weight factors for photon flux.
7084 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7085 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7088 C...Select subprocess to study: skip cases not applicable.
7089 IF(ISET(ISUB).EQ.11) THEN
7090 IF(MSUB(ISUB).NE.1) GOTO 460
7091 C...User process intialization: cross section model dependent.
7092 IF(IABS(IDWTUP).EQ.1) THEN
7093 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7094 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7095 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7097 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7098 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7099 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7100 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7101 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7102 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7104 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7105 & WTGAGA*XSEC(ISUB,1)
7108 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7109 CALL PYSIGH(NCHN,SIGS)
7111 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7112 & WTGAGA*XSEC(ISUB,1)
7113 IF(MSUB(ISUB).NE.1) GOTO 460
7116 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7117 CALL PYSIGH(NCHN,SIGS)
7119 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7120 & WTGAGA*XSEC(ISUB,1)
7121 IF(XSEC(ISUB,1).EQ.0D0) THEN
7127 ELSEIF(ISUB.EQ.96) THEN
7128 IF(MINT(50).EQ.0) GOTO 460
7129 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7131 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7132 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7133 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7134 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7135 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7136 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7138 IF(MSUB(ISUB).NE.1) GOTO 460
7141 IF(ISUB.EQ.96) ISTSB=2
7142 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7144 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7145 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7147 C...Find resonances (explicit or implicit in cross-section).
7150 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7152 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7153 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7155 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7156 & .OR.ISUB.EQ.177) THEN
7158 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7160 IF(MSTP(46).EQ.5) THEN
7163 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7167 IF(CKMX.LE.0D0) CKMX=VINT(1)
7170 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7171 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7174 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7175 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7183 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7184 $ (ISUB.GE.361.AND.ISUB.LE.380))
7187 IF(ISUB.EQ.141) THEN
7189 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7190 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7193 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7194 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7200 ELSEIF(ITECH.EQ.0) THEN
7201 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7210 C...Order the resonances
7211 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7216 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7221 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7228 SHN0=PMAS(KCR1,1)**2
7230 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7231 SHN0=PMAS(KCR2,1)**2
7233 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7234 SHN0=PMAS(KCR3,1)**2
7237 FAR=SQRT(AEM/ALPRHT)
7239 CALL PYTECM(SHN,S1,WIDO,1)
7244 CALL PYTECM(SHN,S1,WIDO,1)
7245 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7248 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7249 ELSEIF(IRES.EQ.0) THEN
7259 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7266 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7273 SHN0=PMAS(KCR1,1)**2
7275 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7276 SHN0=PMAS(KCR2,1)**2
7279 FAR=SQRT(AEM/ALPRHT)
7281 CALL PYTECM(SHN,S1,WIDO,2)
7286 CALL PYTECM(SHN,S1,WIDO,2)
7287 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7290 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7291 ELSEIF(JRES.EQ.0) THEN
7301 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7304 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7305 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7308 VINT(73)=XMAS(1)**2/VINT(2)
7309 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7317 VINT(75)=XMAS(2)**2/VINT(2)
7318 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7326 VINT(77)=XMAS(3)**2/VINT(2)
7327 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7334 C...Charged current: rho+- and a+-
7335 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7338 VINT(73)=YMAS(1)**2/VINT(2)
7339 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7347 VINT(75)=YMAS(2)**2/VINT(2)
7348 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7357 IF(ISUB.NE.141) THEN
7358 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7359 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7360 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7361 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7362 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7363 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7364 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7366 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7368 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7373 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7381 ELSEIF(KFR1.NE.0) THEN
7383 ELSEIF(KFR2.NE.0) THEN
7388 ELSEIF(KFR3.NE.0) THEN
7397 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7399 ELSEIF(KFR2.NE.0) THEN
7414 C...Find product masses and minimum pT of process.
7420 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7424 IF(KFPR(ISUB,I).EQ.0) THEN
7425 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7427 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7428 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7431 C...This prevents SUSY/t particles from becoming too light.
7433 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7436 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7437 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7438 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7439 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7440 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7441 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7442 PMMN(I)=MIN(PMMN(I),PMSUM)
7445 ELSEIF(KFLW.EQ.6) THEN
7446 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7453 CKIN(41)=MAX(PMMN(1),CKIN(41))
7454 CKIN(43)=MAX(PMMN(2),CKIN(43))
7455 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7458 IF(MINT(51).EQ.1) THEN
7459 WRITE(MSTU(11),5100) ISUB
7466 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7467 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7468 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7469 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7470 ELSEIF(ISUB.EQ.96) THEN
7471 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7477 C...Prepare for additional variable choices in 2 -> 3.
7480 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7482 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7483 VINT(204)=PMAS(23,1)
7484 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7485 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7486 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7487 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7488 & VINT(204)=VINT(201)
7490 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7493 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7495 NPTS(1)=2+2*MINT(72)
7496 IF(MINT(47).EQ.1) THEN
7497 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7498 ELSEIF(MINT(47).GE.5) THEN
7499 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7505 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7506 IF(MINT(47).GE.2) NPTS(2)=2
7507 IF(MINT(47).GE.5) NPTS(2)=3
7510 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7512 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7513 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7516 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7517 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7519 C...Reset coefficients of cross-section weighting.
7523 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7524 & .AND.ISUB.LE.380)) THEN
7541 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7542 C...in grid of phase space points.
7548 IF(METAU.EQ.1) GOTO 150
7549 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7550 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7551 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7553 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7557 C...Special case when both resonances have same mass,
7558 C...as is often the case in process 194.
7559 c IF(MINT(72).GE.2) THEN
7560 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7561 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7562 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7564 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7569 CALL PYKMAP(1,MTAU,RTAU)
7570 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7573 IF(METAUP.EQ.1) GOTO 150
7574 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7576 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7577 CALL PYKMAP(4,MTAUP,0.5D0)
7579 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7583 IF(MEYST.EQ.1) GOTO 150
7584 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7585 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7586 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7587 CALL PYKMAP(2,MYST,0.5D0)
7591 IF(MECTH.EQ.1) GOTO 150
7592 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7593 MCTH=1+MOD(ITRY-1,NPTS(4))
7594 CALL PYKMAP(3,MCTH,0.5D0)
7596 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7598 C...Store position and limits.
7601 IF(MINT(51).EQ.1) GOTO 150
7604 MVARPT(NACC,2)=MTAUP
7608 VINTPT(NACC,J)=VINT(10+J)
7611 C...Normal case: calculate cross-section.
7613 CALL PYSIGH(NCHN,SIGS)
7619 C..2 -> 3: find highest value out of a number of tries.
7622 DO 140 IKIN3=1,MSTP(129)
7623 CALL PYKMAP(5,0,0D0)
7624 IF(MINT(51).EQ.1) GOTO 140
7625 CALL PYSIGH(NCHN,SIGTMP)
7630 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7634 C...Store cross-section.
7636 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7637 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7638 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7641 WRITE(MSTU(11),5100) ISUB
7644 ELSEIF(SIGSAM.EQ.0D0) THEN
7645 WRITE(MSTU(11),5300) ISUB
7649 IF(ISUB.NE.96) NPOSI=NPOSI+1
7651 C...Calculate integrals in tau over maximal phase space limits.
7654 ATAU1=LOG(TAUMAX/TAUMIN)
7655 IF(NPTS(1).GE.2) THEN
7656 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7658 IF(NPTS(1).GE.4) THEN
7659 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7660 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7663 IF(NPTS(1).GE.6) THEN
7664 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7665 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7668 IF(NPTS(1).GE.8) THEN
7669 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7670 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7673 IF(IPEAK7.EQ.1) THEN
7674 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7677 C...Reset. Sum up cross-sections in points calculated.
7679 IF(NPTS(IVAR).EQ.1) GOTO 320
7680 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7691 IBIN=MVARPT(IACC,IVAR)
7693 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7695 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7699 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7700 NAREL(IBIN)=NAREL(IBIN)+1
7701 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7703 C...Sum up tau cross-section pieces in points used.
7706 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7707 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7709 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7710 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7711 & ((TAU-TAUR1)**2+GAMR1**2)
7714 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7715 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7716 & ((TAU-TAUR2)**2+GAMR2**2)
7718 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7719 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7720 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7721 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7722 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7723 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7725 IF(MINT(72).EQ.3) THEN
7726 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7727 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7728 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7729 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7731 C...Sum up tau' cross-section pieces in points used.
7732 ELSEIF(IVAR.EQ.2) THEN
7734 TAUP=VINTPT(IACC,16)
7735 TAUPMN=VINTPT(IACC,6)
7736 TAUPMX=VINTPT(IACC,26)
7737 ATAUP1=LOG(TAUPMX/TAUPMN)
7738 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7739 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7740 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7741 & (1D0-TAU/TAUP)**3/TAUP
7743 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7744 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7745 & TAUP/MAX(2D-10,1D0-TAUP)
7748 C...Sum up y* cross-section pieces in points used.
7749 ELSEIF(IVAR.EQ.3) THEN
7751 YSTMIN=VINTPT(IACC,2)
7752 YSTMAX=VINTPT(IACC,22)
7754 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7756 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7757 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7758 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7759 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7760 IF(MINT(45).EQ.3) THEN
7761 TAUE=VINTPT(IACC,11)
7762 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7763 YST0=-0.5D0*LOG(TAUE)
7764 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7765 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7766 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7767 & MAX(1D-10,1D0-EXP(YST-YST0))
7769 IF(MINT(46).EQ.3) THEN
7770 TAUE=VINTPT(IACC,11)
7771 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7772 YST0=-0.5D0*LOG(TAUE)
7773 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7774 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7775 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7776 & MAX(1D-10,1D0-EXP(-YST-YST0))
7779 C...Sum up cos(theta-hat) cross-section pieces in points used.
7781 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7783 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7785 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7788 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7789 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7790 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7791 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7793 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7794 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7795 & MAX(RM34,RSQM-CTH)
7796 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7797 & MAX(RM34,RSQM+CTH)
7798 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7799 & MAX(RM34,RSQM-CTH)**2
7800 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7801 & MAX(RM34,RSQM+CTH)**2
7805 C...Check that equation system solvable.
7806 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7810 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7811 & IRED=1,NBIN),WTREL(IBIN)
7812 IF(NAREL(IBIN).EQ.0) MSOLV=0
7813 WTRELS=WTRELS+WTREL(IBIN)
7815 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7817 C...Solve to find relative importance of cross-section pieces.
7820 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7822 DO 230 IRED=1,NBIN-1
7823 DO 220 IBIN=IRED+1,NBIN
7824 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7828 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7829 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7830 DO 210 ICOE=IRED,NBIN
7831 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7835 DO 250 IRED=NBIN,1,-1
7836 DO 240 ICOE=IRED+1,NBIN
7837 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7839 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7843 C...Share evenly if failure.
7844 260 IF(MSOLV.EQ.0) THEN
7848 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7849 & WTREL(IBIN)/WTRELS)
7853 C...Normalize coefficients, with piece shared democratically.
7857 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7858 COEFSU=COEFSU+COEFU(IBIN)
7859 WTRELS=WTRELS+WTRELN(IBIN)
7861 IF(COEFSU.GT.0D0) THEN
7863 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7864 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7868 COEFO(IBIN)=1D0/NBIN
7871 IF(IVAR.EQ.1) IOFF=0
7872 IF(IVAR.EQ.2) IOFF=17
7873 IF(IVAR.EQ.3) IOFF=7
7874 IF(IVAR.EQ.4) IOFF=12
7878 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
7882 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7883 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
7884 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
7886 COEF(ISUB,ICOF)=COEFO(IBIN)
7890 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7891 & (COEFO(IBIN),IBIN=1,NBIN)
7895 C...Find two most promising maxima among points previously determined.
7903 VINT(10+J)=VINTPT(IACC,J)
7906 CALL PYSIGH(NCHN,SIGS)
7913 DO 350 IKIN3=1,MSTP(129)
7914 CALL PYKMAP(5,0,0D0)
7915 IF(MINT(51).EQ.1) GOTO 350
7916 CALL PYSIGH(NCHN,SIGTMP)
7921 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7926 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7929 DO 370 IMV=NMAX,1,-1
7931 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7932 IACCMX(IMV+1)=IACCMX(IMV)
7933 SIGSMX(IMV+1)=SIGSMX(IMV)
7936 380 IACCMX(IIN)=IACC
7938 IF(NMAX.LE.1) NMAX=NMAX+1
7942 C...Read out starting position for search.
7943 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7948 MTAUP=MVARPT(IACC,2)
7956 C...Starting point and step size in parameter space.
7959 IF(NPTS(IVAR).EQ.1) GOTO 420
7960 IF(IVAR.EQ.1) VVAR=VTAU
7961 IF(IVAR.EQ.2) VVAR=VTAUP
7962 IF(IVAR.EQ.3) VVAR=VYST
7963 IF(IVAR.EQ.4) VVAR=VCTH
7964 IF(IVAR.EQ.1) MVAR=MTAU
7965 IF(IVAR.EQ.2) MVAR=MTAUP
7966 IF(IVAR.EQ.3) MVAR=MYST
7967 IF(IVAR.EQ.4) MVAR=MCTH
7968 IF(IRPT.EQ.1) VDEL=0.1D0
7969 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7971 IF(IRPT.EQ.1) VMAR=0.02D0
7972 IF(IRPT.EQ.2) VMAR=0.002D0
7974 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7977 C...Define new point in parameter space.
7981 ELSEIF(IMOV.EQ.1) THEN
7984 ELSEIF(IMOV.EQ.2) THEN
7987 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7988 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7994 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7995 & VVAR-2D0*VDEL.GT.VMAR) THEN
8001 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8015 C...Convert to relevant variables and find derived new limits.
8019 CALL PYKMAP(1,MTAU,VTAU)
8020 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8022 IF(MINT(51).EQ.1) ILERR=1
8025 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8027 IF(IVAR.EQ.2) VTAUP=VNEW
8028 CALL PYKMAP(4,MTAUP,VTAUP)
8030 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8032 IF(MINT(51).EQ.1) ILERR=1
8034 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8035 IF(IVAR.EQ.3) VYST=VNEW
8036 CALL PYKMAP(2,MYST,VYST)
8038 IF(MINT(51).EQ.1) ILERR=1
8040 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8042 IF(IVAR.EQ.4) VCTH=VNEW
8043 CALL PYKMAP(3,MCTH,VCTH)
8045 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8047 C...Evaluate cross-section. Save new maximum. Final maximum.
8050 ELSEIF(ISTSB.NE.5) THEN
8051 CALL PYSIGH(NCHN,SIGS)
8058 DO 400 IKIN3=1,MSTP(129)
8059 CALL PYKMAP(5,0,0D0)
8060 IF(MINT(51).EQ.1) GOTO 400
8061 CALL PYSIGH(NCHN,SIGTMP)
8066 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8070 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8071 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8072 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8077 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8078 XSEC(ISUB,1)=1.05D0*SIGSAM
8079 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8080 & WTGAGA*XSEC(ISUB,1)
8082 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8083 & PARP(174)*XSEC(ISUB,1)
8084 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8088 C...Print summary table.
8089 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8090 IF(MSTP(127).NE.1) THEN
8091 WRITE(MSTU(11),5900)
8094 WRITE(MSTU(11),6400)
8098 IF(MSTP(122).GE.1) THEN
8099 WRITE(MSTU(11),6000)
8100 WRITE(MSTU(11),6100)
8102 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8103 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8104 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8106 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8107 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8108 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8109 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8110 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8112 WRITE(MSTU(11),6300)
8115 C...Format statements for maximization results.
8116 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8117 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8118 &'cth',9X,'tau''',7X,'sigma')
8119 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8120 &'phase space.'/1X,'Process switched off!')
8121 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8122 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8123 &'cross-section.'/1X,'Process switched off!')
8124 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8125 5500 FORMAT(1X,1P,10D11.3)
8126 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8127 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8128 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8129 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8130 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8131 &'cross-section.'/1X,'Execution stopped!')
8132 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8133 &'cross-section maximum search',1X,8('*'))
8134 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8135 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8136 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8137 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8138 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8139 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8141 &1X,'Execution will stop if you try to generate events.')
8146 C*********************************************************************
8149 C...Initializes multiplicity distribution and selects mutliplicity
8150 C...of pileup events, i.e. several events occuring at the same
8153 SUBROUTINE PYPILE(MPILE)
8155 C...Double precision and integer declarations.
8156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8157 IMPLICIT INTEGER(I-N)
8158 INTEGER PYK,PYCHGE,PYCOMP
8160 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8161 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8162 COMMON/PYINT1/MINT(400),VINT(400)
8163 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8164 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8165 C...Local arrays and saved variables.
8166 DIMENSION WTI(0:200)
8167 SAVE IMIN,IMAX,WTI,WTS
8169 C...Sum of allowed cross-sections for pileup events.
8171 VINT(131)=SIGT(0,0,5)
8172 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8173 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8174 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8175 IF(MSTP(133).LE.0) RETURN
8177 C...Initialize multiplicity distribution at maximum.
8178 XNAVE=VINT(131)*PARP(131)
8179 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8180 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8183 WTN=WTI(INAVE)*INAVE
8185 C...Find shape of multiplicity distribution below maximum.
8187 DO 100 I=INAVE-1,1,-1
8188 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8189 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8190 IF(WTI(I).LT.1D-6) GOTO 110
8196 C...Find shape of multiplicity distribution above maximum.
8198 DO 120 I=INAVE+1,200
8199 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8200 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8201 IF(WTI(I).LT.1D-6) GOTO 130
8208 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8209 & WTS/(WTS+WTI(1)/XNAVE)
8210 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8211 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8213 C...Pick multiplicity of pileup events.
8215 IF(MSTP(133).LE.0) THEN
8216 MINT(81)=MAX(1,MSTP(134))
8222 IF(WTR.LE.0D0) GOTO 150
8228 C...Format statement for error message.
8229 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8230 &'crossing too large, ',1P,D12.4)
8235 C*********************************************************************
8238 C...Saves and restores parameter and cross section values for the
8239 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8240 C...Also makes random choice between alternatives.
8242 SUBROUTINE PYSAVE(ISAVE,IGA)
8244 C...Double precision and integer declarations.
8245 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8246 IMPLICIT INTEGER(I-N)
8247 INTEGER PYK,PYCHGE,PYCOMP
8249 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8251 COMMON/PYINT1/MINT(400),VINT(400)
8252 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8253 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8254 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8255 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8256 C...Local arrays and saved variables.
8257 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8258 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8259 &INTCP(15,20),RECP(15,20)
8260 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8262 C...Save list of subprocesses and cross-section information.
8266 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8269 MSUBCP(IGA,ICP)=MSUB(I)
8271 COEFCP(IGA,ICP,J)=COEF(I,J)
8274 NGENCP(IGA,ICP,J)=NGEN(I,J)
8275 XSECCP(IGA,ICP,J)=XSEC(I,J)
8280 NGENCP(IGA,0,J)=NGEN(0,J)
8281 XSECCP(IGA,0,J)=XSEC(0,J)
8286 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8291 C...Save various common process variables.
8293 INTCP(IGA,J)=MINT(40+J)
8295 INTCP(IGA,11)=MINT(101)
8296 INTCP(IGA,12)=MINT(102)
8297 INTCP(IGA,13)=MINT(107)
8298 INTCP(IGA,14)=MINT(108)
8299 INTCP(IGA,15)=MINT(123)
8301 RECP(IGA,2)=VINT(318)
8303 C...Save cross-section information only.
8304 ELSEIF(ISAVE.EQ.2) THEN
8305 DO 190 ICP=1,NCP(IGA)
8308 NGENCP(IGA,ICP,J)=NGEN(I,J)
8309 XSECCP(IGA,ICP,J)=XSEC(I,J)
8313 NGENCP(IGA,0,J)=NGEN(0,J)
8314 XSECCP(IGA,0,J)=XSEC(0,J)
8317 C...Choose between allowed alternatives.
8318 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8321 DO 210 IG=1,MINT(121)
8322 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8324 XSUMCP=XSUMCP*PYR(0)
8325 DO 220 IG=1,MINT(121)
8327 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8328 IF(XSUMCP.LE.0D0) GOTO 230
8333 C...Restore cross-section information.
8337 DO 270 ICP=1,NCP(IGA)
8339 MSUB(I)=MSUBCP(IGA,ICP)
8341 COEF(I,J)=COEFCP(IGA,ICP,J)
8344 NGEN(I,J)=NGENCP(IGA,ICP,J)
8345 XSEC(I,J)=XSECCP(IGA,ICP,J)
8349 NGEN(0,J)=NGENCP(IGA,0,J)
8350 XSEC(0,J)=XSECCP(IGA,0,J)
8355 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8360 C...Restore various common process variables.
8362 MINT(40+J)=INTCP(IGA,J)
8364 MINT(101)=INTCP(IGA,11)
8365 MINT(102)=INTCP(IGA,12)
8366 MINT(107)=INTCP(IGA,13)
8367 MINT(108)=INTCP(IGA,14)
8368 MINT(123)=INTCP(IGA,15)
8371 VINT(318)=RECP(IGA,2)
8373 C...Sum up cross-section info (for PYSTAT).
8374 ELSEIF(ISAVE.EQ.5) THEN
8385 DO 350 IG=1,MINT(121)
8386 DO 340 ICP=1,NCP(IG)
8388 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8389 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8390 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8391 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8393 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8394 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8395 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8396 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8403 C*********************************************************************
8406 C...For lepton beams it gives photon-hadron or photon-photon systems
8407 C...to be treated with the ordinary machinery and combines this with a
8408 C...description of the lepton -> lepton + photon branching.
8410 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8412 C...Double precision and integer declarations.
8413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8414 IMPLICIT INTEGER(I-N)
8415 INTEGER PYK,PYCHGE,PYCOMP
8417 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8418 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8420 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8421 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8422 COMMON/PYINT1/MINT(400),VINT(400)
8423 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8424 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8426 C...Local variables and data statement.
8427 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8428 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8429 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8432 C...Initialize generation of photons inside leptons.
8435 C...Save quantities on incoming lepton system.
8439 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8441 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8442 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8443 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8445 C...Calculate range of x and Q2 values allowed in generation.
8447 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8448 IF(MINT(140+I).NE.0) THEN
8449 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8450 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8452 YMIN=MAX(CKIN(71+2*I),EPS)
8453 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8454 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8455 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8456 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8457 THEMIN=MAX(CKIN(67+2*I),0D0)
8458 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8459 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8460 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8461 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8462 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8463 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8464 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8465 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8466 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8467 C...W limits when lepton on one side only.
8468 IF(MINT(143-I).EQ.0) THEN
8469 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8470 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8471 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8476 C...W limits when lepton on both sides.
8477 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8478 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8479 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8480 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8481 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8482 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8483 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8484 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8485 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8486 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8488 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8489 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8493 C...Q2 and W values and photon flux weight factors for initialization.
8494 ELSEIF(IGAGA.EQ.2) THEN
8499 C...W value for photon on one or both sides, and for processes
8500 C...with gamma-gamma cross section peaked at small shat.
8501 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8502 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8503 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8504 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8505 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8506 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8507 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8509 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8510 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8512 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8514 C...Upper estimate of photon flux weight factor.
8515 C...Initialization Q2 scale. Flag incoming unresolved photon.
8518 IF(MINT(140+I).NE.0) THEN
8519 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8520 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8521 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8523 Q2INIT=5D0+Q2MIN(3-I)
8524 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8525 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8526 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8527 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8528 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8529 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8531 ELSEIF(ISUB.EQ.140) THEN
8536 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8537 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8539 VINT(306+I)=VINT(2+I)**2
8544 C...Update pTmin and cross section information.
8545 IF(MSTP(82).LE.1) THEN
8546 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8548 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8550 VINT(149)=4D0*PTMN**2/VINT(2)
8555 C...Generate photons inside leptons and
8556 C...calculate photon flux weight factors.
8557 ELSEIF(IGAGA.EQ.3) THEN
8562 C...Generate phase space point and check against cuts.
8566 IF(MINT(140+I).NE.0) THEN
8568 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8569 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8570 C...Cuts on internal consistency in x and Q2.
8571 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8572 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8573 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8574 C...Cuts on y and theta.
8575 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8576 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8577 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8578 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8579 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8580 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8581 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8584 C...Phi angle isotropic. Reconstruct pT.
8585 PHI(I)=PARU(2)*PYR(0)
8586 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8587 & PMS(I))*SIN(THETA(I))
8589 C...Store info on variables selected, for documentation purposes.
8590 VINT(2+I)=-SQRT(Q2(I))
8594 VINT(310+I)=THETA(I)
8605 C...Cut on W combines info from two sides.
8606 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8607 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8608 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8609 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8610 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8611 IF(W2.LT.W2MIN) GOTO 120
8612 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8615 ELSEIF(MINT(141).NE.0) THEN
8616 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8619 ELSEIF(MINT(142).NE.0) THEN
8620 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8625 C...Store kinematics info for photon(s) in subsystem cm frame.
8630 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8631 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8632 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8635 VINT(298)=-VINT(293)
8636 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8637 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8639 C...Assign weight for photon flux; different for transverse and
8640 C...longitudinal photons. Flag incoming unresolved photon.
8643 IF(MINT(140+I).NE.0) THEN
8644 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8645 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8646 IF(MSTP(16).EQ.0) THEN
8649 WTGAGA=WTGAGA*X(I)/Y(I)
8652 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8653 WTGAGA=WTGAGA*(1D0-XY)
8654 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8655 WTGAGA=WTGAGA*(1D0-XY)
8656 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8657 WTGAGA=WTGAGA*(1D0-XY)
8659 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8660 & PMS(I)*XY**2/Q2(I))
8662 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8668 C...Update pTmin and cross section information.
8669 IF(MSTP(82).LE.1) THEN
8670 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8672 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8674 VINT(149)=4D0*PTMN**2/VINT(2)
8678 C...Reconstruct kinematics of photons inside leptons.
8679 ELSEIF(IGAGA.EQ.4) THEN
8681 C...Make place for incoming particles and scattered leptons.
8683 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8684 MINT(4)=MINT(4)+MOVE
8685 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8686 IF(K(I,1).EQ.21) THEN
8692 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8693 & K(I+MOVE,3)=K(I,3)+MOVE
8694 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8695 & K(I+MOVE,4)=K(I,4)+MOVE
8696 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8697 & K(I+MOVE,5)=K(I,5)+MOVE
8700 DO 170 I=MINT(84)+1,N
8701 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8702 & K(I,3)=K(I,3)+MOVE
8705 C...Fill in incoming particles.
8706 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8715 IF(MINT(140+I).NE.0) THEN
8716 K(MINT(83)+I,2)=MINT(140+I)
8717 P(MINT(83)+I,5)=VINT(302+I)
8719 K(MINT(83)+I,2)=MINT(10+I)
8720 P(MINT(83)+I,5)=VINT(2+I)
8722 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8723 & VINT(302))*(-1D0)**(I+1)
8724 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8727 C...New mother-daughter relations in documentation section.
8728 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8729 K(MINT(83)+1,4)=MINT(83)+3
8730 K(MINT(83)+1,5)=MINT(83)+5
8731 K(MINT(83)+2,4)=MINT(83)+4
8732 K(MINT(83)+2,5)=MINT(83)+6
8733 K(MINT(83)+3,3)=MINT(83)+1
8734 K(MINT(83)+5,3)=MINT(83)+1
8735 K(MINT(83)+4,3)=MINT(83)+2
8736 K(MINT(83)+6,3)=MINT(83)+2
8737 ELSEIF(MINT(141).NE.0) THEN
8738 K(MINT(83)+1,4)=MINT(83)+3
8739 K(MINT(83)+1,5)=MINT(83)+4
8740 K(MINT(83)+2,4)=MINT(83)+5
8741 K(MINT(83)+3,3)=MINT(83)+1
8742 K(MINT(83)+4,3)=MINT(83)+1
8743 K(MINT(83)+5,3)=MINT(83)+2
8744 ELSEIF(MINT(142).NE.0) THEN
8745 K(MINT(83)+1,4)=MINT(83)+4
8746 K(MINT(83)+2,4)=MINT(83)+3
8747 K(MINT(83)+2,5)=MINT(83)+5
8748 K(MINT(83)+3,3)=MINT(83)+2
8749 K(MINT(83)+4,3)=MINT(83)+1
8750 K(MINT(83)+5,3)=MINT(83)+2
8753 C...Fill scattered lepton(s).
8755 IF(MINT(140+I).NE.0) THEN
8756 LSC=MINT(83)+MIN(I+2,MOVE)
8758 K(LSC,2)=MINT(140+I)
8759 P(LSC,1)=PT(I)*COS(PHI(I))
8760 P(LSC,2)=PT(I)*SIN(PHI(I))
8761 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8762 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8764 P(LSC,5)=VINT(302+I)
8768 C...Find incoming four-vectors to subprocess.
8770 IF(MINT(141).NE.0) THEN
8772 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8776 P(N+1,J)=P(MINT(83)+1,J)
8780 IF(MINT(142).NE.0) THEN
8782 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8786 P(N+2,J)=P(MINT(83)+2,J)
8790 C...Define boost and rotation between hadronic subsystem and
8791 C...collision rest frame; boost hadronic subsystem to this frame.
8793 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8795 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8796 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8797 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8798 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8799 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8802 C...Add on scattered leptons to final state.
8804 IF(MINT(140+I).NE.0) THEN
8805 LSC=MINT(83)+MIN(I+2,MOVE)
8821 C*********************************************************************
8824 C...Generates quantities characterizing the high-pT scattering at the
8825 C...parton level according to the matrix elements. Chooses incoming,
8826 C...reacting partons, their momentum fractions and one of the possible
8831 C...Double precision and integer declarations.
8832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8833 IMPLICIT INTEGER(I-N)
8834 INTEGER PYK,PYCHGE,PYCOMP
8835 C...Parameter statement to help give large particle numbers.
8836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8837 &KEXCIT=4000000,KDIMEN=5000000)
8839 C...User process initialization and event commonblocks.
8841 PARAMETER (MAXPUP=100)
8842 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8843 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8844 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8845 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8848 PARAMETER (MAXNUP=500)
8849 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8850 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8851 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8852 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8853 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8854 SAVE /HEPRUP/,/HEPEUP/
8857 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8858 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8859 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8860 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8861 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8862 COMMON/PYINT1/MINT(400),VINT(400)
8863 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8864 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8865 COMMON/PYINT4/MWID(500),WIDS(500,5)
8866 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8867 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8868 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8869 COMMON/PYTCCO/COEFX(194:380,2)
8870 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
8871 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8872 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
8875 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8877 C...Parameters and data used in elastic/diffractive treatment.
8878 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8879 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8881 C...Initial values, specifically for (first) semihard interaction.
8890 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8899 C...Start by assuming incoming photon is entering subprocess.
8900 IF(MINT(11).EQ.22) THEN
8902 VINT(307)=VINT(3)**2
8904 IF(MINT(12).EQ.22) THEN
8906 VINT(308)=VINT(4)**2
8911 C...Choice of process type - first event of pileup.
8913 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8914 ELSEIF(MINT(82).EQ.1) THEN
8916 C...For gamma-p or gamma-gamma first pick between alternatives.
8918 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8921 C...For real gamma + gamma with different nature, flip at random.
8922 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8923 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8933 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8936 C...Pick process type, possibly by user process machinery.
8937 C...(If the latter, also event will be picked here.)
8938 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8941 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8946 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8947 & ISUB.LT.500) GOTO 110
8949 RSUB=XSEC(0,1)*PYR(0)
8951 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8954 IF(RSUB.LE.0D0) GOTO 130
8956 130 IF(ISUB.EQ.95) ISUB=96
8957 IF(ISUB.EQ.96) INMULT=1
8958 IF(ISET(ISUB).EQ.11) THEN
8965 C...Choice of inclusive process type - pileup events.
8966 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8967 RSUB=VINT(131)*PYR(0)
8969 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8970 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8971 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8972 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8974 IF(ISUB.EQ.96) INMULT=1
8977 C...Choice of photon energy and flux factor inside lepton.
8978 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8979 CALL PYGAGA(3,WTGAGA)
8980 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8981 CKIN(3)=MAX(VINT(285),VINT(154))
8984 C...When necessary set direct/resolved photon by hand.
8985 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8986 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8987 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8990 C...Restrict direct*resolved processes to pTmin >= Q,
8991 C...to avoid doublecounting with DIS.
8992 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8993 IF(MINT(15).EQ.22) THEN
8994 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
8996 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9001 C...Set up for multiple interactions (may include impact parameter).
9002 IF(INMULT.EQ.1) THEN
9003 IF(MINT(35).LE.1) CALL PYMULT(2)
9004 IF(MINT(35).GE.2) CALL PYMIGN(2)
9007 C...Loopback point for minimum bias in photon physics.
9010 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9011 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9012 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9013 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9017 C...Random choice of flavour for some SUSY processes.
9018 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9019 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9020 IF(ISUB.EQ.210) THEN
9021 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9022 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9023 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9024 ELSEIF(ISUB.EQ.213) THEN
9025 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9026 KFPR(ISUB,2)=KFPR(ISUB,1)
9027 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9028 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9030 IF(ISUB.GE.258) THEN
9035 IF(MOD(ISUB,2).EQ.0) THEN
9036 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9038 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9040 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9041 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9042 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9045 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9048 ELSEIF(PYR(0).LT.0.5D0) THEN
9055 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9056 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9057 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9058 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9059 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9060 KFPR(ISUB,2)=KFPR(ISUB,1)
9061 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9062 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9063 KFPR(ISUB,2)=KFPR(ISUB,1)
9064 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9065 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9066 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9069 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9072 ELSEIF(PYR(0).LT.0.5D0) THEN
9079 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9084 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9088 C...Find resonances (explicit or implicit in cross-section).
9091 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9093 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9094 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9096 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9099 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9101 IF(MSTP(46).EQ.5) THEN
9104 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9108 IF(CKMX.LE.0D0) CKMX=VINT(1)
9111 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9112 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9115 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9116 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9124 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9125 $(ISUB.GE.361.AND.ISUB.LE.380))
9128 IF(ISUB.EQ.141) THEN
9130 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9131 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9134 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9135 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9141 C...3 resonances at work: rho, omega, a
9142 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9143 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9146 VINT(73)=XMAS(1)**2/VINT(2)
9147 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9153 VINT(75)=XMAS(2)**2/VINT(2)
9154 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9160 VINT(77)=XMAS(3)**2/VINT(2)
9161 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9166 C...Charged current: rho+- and a+-
9167 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9170 VINT(73)=YMAS(1)**2/VINT(2)
9171 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9177 VINT(75)=YMAS(2)**2/VINT(2)
9178 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9185 IF(ISUB.NE.141) THEN
9186 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9188 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9190 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9195 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9203 ELSEIF(KFR1.NE.0) THEN
9205 ELSEIF(KFR2.NE.0) THEN
9210 ELSEIF(KFR3.NE.0) THEN
9219 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9221 ELSEIF(KFR2.NE.0) THEN
9236 C...Find product masses and minimum pT of process,
9237 C...optionally with broadening according to a truncated Breit-Wigner.
9242 IF(MINT(82).GE.2) VINT(71)=0D0
9244 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9248 IF(KFPR(ISUB,I).EQ.0) THEN
9249 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9251 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9254 C...This prevents SUSY/t particles from becoming too light.
9256 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9259 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9260 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9261 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9262 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9263 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9264 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9265 PMMN(I)=MIN(PMMN(I),PMSUM)
9268 ELSEIF(KFLW.EQ.6) THEN
9269 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9276 CKIN(41)=MAX(PMMN(1),CKIN(41))
9277 CKIN(43)=MAX(PMMN(2),CKIN(43))
9278 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9281 IF(MINT(51).EQ.1) THEN
9282 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9292 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9293 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9296 C...Prepare for additional variable choices in 2 -> 3.
9299 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9301 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9302 VINT(204)=PMAS(23,1)
9303 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9304 & VINT(204)=PMAS(24,1)
9305 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9306 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9307 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9308 & VINT(204)=VINT(201)
9310 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9313 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9314 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9315 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9316 VRN=PYR(0)*SIGT(0,0,5)
9317 IF(MINT(101).LE.1) THEN
9324 IF(MINT(102).LE.1) THEN
9335 VRN=VRN-SIGT(I1,I2,5)
9336 IF(VRN.LE.0D0) GOTO 190
9339 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9340 IF(MINT(102).GE.2) MINT(104)=KFV2
9344 C...Elastic scattering or single or double diffractive scattering.
9346 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9351 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9353 VRN=PYR(0)*SIGT(0,0,JJ)
9354 IF(MINT(101).LE.1) THEN
9361 IF(MINT(102).LE.1) THEN
9372 VRN=VRN-SIGT(I1,I2,JJ)
9373 IF(VRN.LE.0D0) GOTO 220
9376 220 IF(MINT(101).GE.2) THEN
9380 IF(MINT(102).GE.2) THEN
9388 C...Select mass for GVMD states (rejecting previous assignment).
9390 Q1S=4D0*VINT(154)**2
9394 IF(MINT(106+JT).EQ.3) THEN
9396 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9397 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9398 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9399 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9402 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9403 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9408 C...Side/sides of diffractive system.
9411 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9412 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9414 C...Find masses of particles and minimal masses of diffractive states.
9417 VINT(68+JT)=PDIF(JT)
9418 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9425 SMRES1=(PMM(1)+PMRC)**2
9426 SMRES2=(PMM(2)+PMRC)**2
9428 C...Find elastic slope and lower limit diffractive slope.
9429 IHA=MAX(2,IABS(MINT(103))/110)
9431 IHB=MAX(2,IABS(MINT(104))/110)
9434 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9435 ELSEIF(ISUB.EQ.92) THEN
9436 BMN=MAX(2D0,2D0*BHAD(IHB))
9437 ELSEIF(ISUB.EQ.93) THEN
9438 BMN=MAX(2D0,2D0*BHAD(IHA))
9439 ELSEIF(ISUB.EQ.94) THEN
9443 C...Determine maximum possible t range and coefficient of generation.
9444 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9445 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9446 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9447 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9448 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9449 & (SQM1*SQM4-SQM2*SQM3)/SH
9450 THL=-0.5D0*(THA+THB)
9452 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9454 C...Select diffractive mass/masses according to dm^2/m^2.
9458 IF(MINT(16+JT).EQ.0) THEN
9462 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9463 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9469 C..Additional mass factors, including resonance enhancement.
9470 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9471 IF(LOOP3.LT.100) GOTO 260
9475 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9476 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9477 ELSEIF(ISUB.EQ.93) THEN
9478 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9479 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9480 ELSEIF(ISUB.EQ.94) THEN
9481 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9482 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9483 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9484 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9487 C...Select t according to exp(Bmn*t) and correct to right slope.
9488 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9491 BADD=2D0*ALP*LOG(SH/SQM3)
9492 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9493 ELSEIF(ISUB.EQ.93) THEN
9494 BADD=2D0*ALP*LOG(SH/SQM4)
9495 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9496 ELSEIF(ISUB.EQ.94) THEN
9497 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9499 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9502 C...Check whether m^2 and t choices are consistent.
9503 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9504 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9505 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9506 IF(THB.LE.1D-8) GOTO 260
9507 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9508 & (SQM1*SQM4-SQM2*SQM3)/SH
9509 THLM=-0.5D0*(THA+THB)
9511 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9513 C...Information to output.
9516 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9518 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9521 VINT(283)=PMM(1)**2/4D0
9522 VINT(284)=PMM(2)**2/4D0
9524 C...Note: in the following, by In is meant the integral over the
9525 C...quantity multiplying coefficient cn.
9526 C...Choose tau according to h1(tau)/tau, where
9527 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9528 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9529 C...I1/I5*c5*1/(tau+tau_R') +
9530 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9531 C...I1/I7*c7*tau/(1.-tau), and
9532 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9533 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9535 IF(MINT(51).NE.0) THEN
9536 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9545 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9546 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9547 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9548 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9550 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9551 & COEF(ISUB,5)) MTAU=6
9552 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9553 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9554 C...Additional check to handle techni-processes with extra resonance
9555 C....Only modify tau treatment
9556 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9558 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9559 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9560 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9561 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9562 & +COEFX(ISUB,1)) MTAU=9
9564 CALL PYKMAP(1,MTAU,PYR(0))
9566 C...2 -> 3, 4 processes:
9567 C...Choose tau' according to h4(tau,tau')/tau', where
9568 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9569 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9570 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9572 IF(MINT(51).NE.0) THEN
9573 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9582 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9583 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9584 CALL PYKMAP(4,MTAUP,PYR(0))
9587 C...Choose y* according to h2(y*), where
9588 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9589 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9590 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9591 C...and c1 + c2 + c3 + c4 + c5 = 1.
9593 IF(MINT(51).NE.0) THEN
9594 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9603 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9604 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9605 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9606 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9607 & COEF(ISUB,11)) MYST=5
9608 CALL PYKMAP(2,MYST,PYR(0))
9610 C...2 -> 2 processes:
9611 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9612 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9613 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9614 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9615 C...and c0 + c1 + c2 + c3 + c4 = 1.
9617 IF(MINT(51).NE.0) THEN
9618 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9625 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9628 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9629 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9630 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9631 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9632 & COEF(ISUB,16)) MCTH=5
9633 CALL PYKMAP(3,MCTH,PYR(0))
9636 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9638 CALL PYKMAP(5,0,0D0)
9639 IF(MINT(51).NE.0) THEN
9640 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9649 C...DIS as f + gamma* -> f process: set dummy values.
9650 ELSEIF(ISTSB.EQ.8) THEN
9657 C...Low-pT or multiple interactions (first semihard interaction).
9658 ELSEIF(ISTSB.EQ.9) THEN
9659 IF(MINT(35).LE.1) CALL PYMULT(3)
9660 IF(MINT(35).GE.2) CALL PYMIGN(3)
9663 C...Study user-defined process: kinematics plus weight.
9664 ELSEIF(ISTSB.EQ.11) THEN
9665 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9666 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9671 IF(MINT(82).EQ.1) THEN
9672 NGEN(0,1)=NGEN(0,1)-1
9673 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9675 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9679 C...Extract cross section event weight.
9680 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9683 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9685 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9686 VINT(97)=SIGN(1D0,XWGTUP)
9688 VINT(97)=1D-9*XWGTUP
9691 C...Construct 'trivial' kinematical variables needed.
9694 VINT(41)=PUP(4,1)/EBMUP(1)
9695 VINT(42)=PUP(4,2)/EBMUP(2)
9696 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
9697 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
9698 & '(listing follows):')
9701 VINT(21)=VINT(41)*VINT(42)
9702 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9703 VINT(44)=VINT(21)*VINT(2)
9704 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9706 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9707 VINT(56)=VINT(55)**2
9711 C...Construct other kinematical variables needed (approximately).
9714 VINT(45)=-0.5D0*VINT(44)
9715 VINT(46)=-0.5D0*VINT(44)
9724 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9725 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9727 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9728 & '(PYRAND:) unacceptable ISTUP code for particles')
9729 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9730 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9731 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9734 VINT(47)=SQRT(VINT(48))
9737 C...Choose azimuthal angle.
9739 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9741 C...Check against user cuts on kinematics at parton level.
9743 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9744 IF(MINT(51).NE.0) THEN
9745 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9752 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9754 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9757 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9766 C...Calculate differential cross-section for different subprocesses.
9767 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9769 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9771 C...Multiply cross section by lepton -> photon flux factor.
9772 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9775 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9777 SIGLPT=WTGAGA*SIGLPT
9780 C...Multiply cross-section by user-defined weights.
9781 IF(MSTP(173).EQ.1) THEN
9784 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9786 SIGLPT=PARP(173)*SIGLPT
9792 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9793 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9794 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9797 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9800 C...Calculations for Monte Carlo estimate of all cross-sections.
9801 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9802 IF(MSTP(142).LE.1) THEN
9803 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9805 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9807 ELSEIF(MINT(82).EQ.1) THEN
9808 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9810 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9811 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9813 C...Multiple interactions: store results of cross-section calculation.
9814 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9816 IF(MINT(35).LE.1) CALL PYMULT(4)
9817 IF(MINT(35).GE.2) CALL PYMIGN(4)
9820 C...Ratio of actual to maximum cross section.
9821 IF(ISTSB.NE.11) THEN
9822 VIOL=SIGSWT/XSEC(ISUB,1)
9823 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9824 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9825 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9826 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9827 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9832 C...Check that weight not negative.
9833 IF(MSTP(123).LE.0) THEN
9834 IF(VIOL.LT.-1D-3) THEN
9835 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9836 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9837 & VINT(22),VINT(23),VINT(26)
9841 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9843 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9844 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9845 & VINT(22),VINT(23),VINT(26)
9849 C...Weighting using estimate of maximum of differential cross-section.
9851 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9852 IF(VIOL.LT.PYR(0)) THEN
9853 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9854 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9857 ELSEIF(MFAIL.EQ.0) THEN
9858 RATND=SIGLPT/XSEC(95,1)
9860 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9861 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9862 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9863 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9867 IF(VIOL.LT.PYR(0)) THEN
9870 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9871 IF(VIOL.LT.PYR(0)) THEN
9873 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9877 RATND=SIGLPT/XSEC(95,1)
9878 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9880 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9884 IF(VIOL.LT.PYR(0)) THEN
9885 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9890 C...Check for possible violation of estimated maximum of differential
9891 C...cross-section used in weighting.
9892 IF(MSTP(123).LE.0) THEN
9893 IF(VIOL.GT.1D0) THEN
9894 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9895 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9896 & VINT(22),VINT(23),VINT(26)
9899 ELSEIF(MSTP(123).EQ.1) THEN
9900 IF(VIOL.GT.VINT(108)) THEN
9902 IF(VIOL.GT.1.0001D0) THEN
9904 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9905 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9906 & VINT(22),VINT(23),VINT(26)
9909 ELSEIF(VIOL.GT.VINT(108)) THEN
9911 IF(VIOL.GT.1D0) THEN
9913 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9914 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9916 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9917 IF(KFPR(ISUB,1).LE.9) THEN
9918 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9919 & XMAXUP(KFPR(ISUB,1))
9920 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9921 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9922 & XMAXUP(KFPR(ISUB,1))
9924 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9925 & XMAXUP(KFPR(ISUB,1))
9928 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9929 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9930 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9931 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9932 & XSEC(0,1)=XSEC(0,1)+XDIF
9933 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9934 & VINT(22),VINT(23),VINT(26)
9936 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9937 ELSEIF(ISUB.LE.99) THEN
9938 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9940 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9947 C...Multiple interactions: choose impact parameter (if not already done).
9948 IF(MINT(39).EQ.0) VINT(148)=1D0
9949 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9950 &MSTP(82).GE.3) THEN
9951 IF(MINT(35).LE.1) CALL PYMULT(5)
9952 IF(MINT(35).GE.2) CALL PYMIGN(5)
9953 IF(VINT(150).LT.PYR(0)) THEN
9954 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9962 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9963 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9964 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9965 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9967 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9969 C...Choose flavour of reacting partons (and subprocess).
9970 IF(ISTSB.GE.11) GOTO 320
9973 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9974 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9975 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9976 &PYR(0).GT.RQQBAR)) THEN
9980 MINT(2)=ISIG(ICHN,3)
9981 RSIGS=RSIGS-SIGH(ICHN)
9982 IF(RSIGS.LE.0D0) GOTO 320
9985 C...Multiple interactions: choose qqbar preferentially at small pT.
9986 ELSEIF(ISUB.EQ.96) THEN
9989 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9992 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9995 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
9997 C...Low-pT: choose string drawing configuration.
10003 IF(RSIGS.GT.1D0) MINT(2)=2
10004 IF(RSIGS.GT.2D0) MINT(2)=3
10007 C...Reassign QCD process. Partons before initial state radiation.
10008 320 IF(MINT(2).GT.10) THEN
10010 MINT(2)=MOD(MINT(2),10)
10012 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10023 C...Calculate x value of photon for parton inside photon inside e.
10028 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10029 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10030 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10031 IF(MSPLI.EQ.2) THEN
10035 MINT(105)=MINT(102+JT)
10036 MINT(109)=MINT(106+JT)
10037 VINT(120)=VINT(2+JT)
10038 IF(MSTP(57).LE.1) THEN
10039 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10041 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10044 IF(MSTP(13).EQ.2) THEN
10045 Q2PMS=Q2HRD/PMAS(11,1)**2
10046 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10048 330 XE=XHRD**PYR(0)
10049 XG=MIN(1D0-1D-10,XHRD/XE)
10050 IF(MSTP(57).LE.1) THEN
10051 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10053 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10055 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10056 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10057 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10061 XSFX(JT,KFLS)=XPQ(KFLS)
10066 C...Pick scale where photon is resolved.
10070 IF(MINT(107).EQ.3) THEN
10071 IF(MSTP(66).EQ.1) THEN
10072 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10073 ELSEIF(MSTP(66).EQ.2) THEN
10075 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10076 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10077 Q2INT=SQRT(Q0S*Q2EFF)
10078 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10079 ELSEIF(MSTP(66).EQ.3) THEN
10080 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10081 ELSEIF(MSTP(66).GE.4) THEN
10082 PS=0.25D0*VINT(3)**2
10083 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10084 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10088 IF(MINT(108).EQ.3) THEN
10089 IF(MSTP(66).EQ.1) THEN
10090 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10091 ELSEIF(MSTP(66).EQ.2) THEN
10093 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10094 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10095 Q2INT=SQRT(Q0S*Q2EFF)
10096 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10097 ELSEIF(MSTP(66).EQ.3) THEN
10098 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10099 ELSEIF(MSTP(66).GE.4) THEN
10100 PS=0.25D0*VINT(4)**2
10101 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10102 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10105 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10107 C...Format statements for differential cross-section maximum violations.
10108 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10109 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10110 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10111 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10112 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10114 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10115 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10116 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10118 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10119 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10120 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10121 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10122 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10123 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10128 C*********************************************************************
10131 C...Finds outgoing flavours and event type; sets up the kinematics
10132 C...and colour flow of the hard scattering
10136 C...Double precision and integer declarations
10137 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10138 IMPLICIT INTEGER(I-N)
10139 INTEGER PYK,PYCHGE,PYCOMP
10140 C...Parameter statement to help give large particle numbers.
10141 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10142 &KEXCIT=4000000,KDIMEN=5000000)
10143 C...Parameter statement for maximum size of showers.
10144 PARAMETER (MAXNUR=1000)
10146 C...User process event common block.
10148 PARAMETER (MAXNUP=500)
10149 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10150 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10151 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10152 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10153 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10157 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10158 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10160 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10161 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10162 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10163 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10164 COMMON/PYINT1/MINT(400),VINT(400)
10165 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10166 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10167 COMMON/PYINT4/MWID(500),WIDS(500,5)
10168 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10169 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10170 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10171 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10172 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10173 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10175 C...Local arrays and saved variables
10176 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10177 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10180 C...Read out process
10184 C...Restore information for low-pT processes
10185 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10187 100 VINT(J)=VINTSV(J)
10190 C...Convert H' or A process into equivalent H one
10193 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10194 &ISUB.LE.190)) THEN
10196 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10198 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10199 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10200 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10201 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10202 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10203 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10204 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10205 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10206 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10207 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10208 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10209 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10212 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10214 C...Convert bottomonium process into equivalent charmonium ones.
10215 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10217 C...Choice of subprocess, number of documentation lines
10219 IF(ISUB.EQ.95) IDOC=8
10220 IF(ISET(ISUB).EQ.5) IDOC=9
10221 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10223 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10232 C...Reset K, P and V vectors. Store incoming particles
10233 DO 120 JT=1,MSTP(126)+100
10235 IF(I.GT.MSTU(4)) GOTO 120
10247 P(I,J)=VINT(285+5*JT+J)
10253 C...Store incoming partons in their CM-frame. Save pdf value.
10256 SHP=VINT(26)*VINT(2)
10259 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10264 K(I,3)=MINT(83)+2+JT
10265 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10266 P(I,4)=0.5D0*SHUSER
10267 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10270 C...Copy incoming partons to documentation lines
10282 C...Choose new quark/lepton flavour for relevant annihilation graphs
10283 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10284 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10286 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10287 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10288 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10289 DO 190 I=1,MDCY(IGLGA,3)
10290 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10291 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10292 IF(RKFL.LE.0D0) GOTO 200
10295 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
10296 IF(KFLF.GE.4) GOTO 180
10297 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
10300 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
10303 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10304 & .AND.IABS(KFLF).GE.3) THEN
10305 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10307 FACCIB=VINT(46)**2/RTCM(41)**4
10308 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10309 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10312 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10313 IF(KFLF.EQ.5) GOTO 180
10314 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10315 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10316 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10317 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10321 C...Final state flavours and colour flow: default values
10328 KCS=ISIGN(1,MINT(15))
10330 IF(ISET(ISUB).EQ.11) THEN
10331 C...User-defined processes: find products
10334 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10335 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10336 MINT(21+IUP)=IDUP(IUP)
10337 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10338 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10339 ELSEIF(IDUP(IUP).EQ.0) THEN
10342 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10346 ELSEIF(ISUB.LE.10) THEN
10348 C...f + fbar -> gamma*/Z0
10351 ELSEIF(ISUB.EQ.2) THEN
10352 C...f + fbar' -> W+/-
10353 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10354 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10355 KFRES=ISIGN(24,KCH1+KCH2)
10357 ELSEIF(ISUB.EQ.3) THEN
10358 C...f + fbar -> h0 (or H0, or A0)
10361 ELSEIF(ISUB.EQ.4) THEN
10362 C...gamma + W+/- -> W+/-
10364 ELSEIF(ISUB.EQ.5) THEN
10369 PMQ(1)=PYMASS(MINT(21))
10370 PMQ(2)=PYMASS(MINT(22))
10371 220 JT=INT(1.5D0+PYR(0))
10372 ZMIN=2D0*PMQ(JT)/SHPR
10373 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10374 & (SHPR*(SHPR-PMQ(3-JT)))
10375 ZMAX=MIN(1D0-XH,ZMAX)
10376 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10377 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10378 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10379 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10380 IF(SQC1.LT.1D-8) GOTO 220
10382 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10383 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10384 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10385 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10386 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10387 IF(SQC1.LT.1D-8) GOTO 220
10389 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10390 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10391 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10392 PHIR=PARU(2)*PYR(0)
10394 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10395 & SQRT(1D0-CTHE(2)**2)*CPHI
10397 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10398 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10399 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10400 & PMQ(3-JT)**2/SHP))
10401 ZMIN=2D0*PMQ(3-JT)/SHPR
10402 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10403 ZMAX=MIN(1D0-XH,ZMAX)
10404 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10408 ELSEIF(ISUB.EQ.6) THEN
10409 C...Z0 + W+/- -> W+/-
10411 ELSEIF(ISUB.EQ.7) THEN
10414 ELSEIF(ISUB.EQ.8) THEN
10421 RVCKM=VINT(180+I)*PYR(0)
10424 IPM=(5-ISIGN(1,I))/2
10426 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10427 MINT(20+JT)=ISIGN(IB,I)
10428 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10429 IF(RVCKM.LE.0D0) GOTO 250
10432 IB=2*((IA+1)/2)-1+MOD(IA,2)
10433 MINT(20+JT)=ISIGN(IB,I)
10435 250 PMQ(JT)=PYMASS(MINT(20+JT))
10437 JT=INT(1.5D0+PYR(0))
10438 ZMIN=2D0*PMQ(JT)/SHPR
10439 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10440 & (SHPR*(SHPR-PMQ(3-JT)))
10441 ZMAX=MIN(1D0-XH,ZMAX)
10442 IF(ZMIN.GE.ZMAX) GOTO 230
10443 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10444 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10445 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10446 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10447 IF(SQC1.LT.1D-8) GOTO 230
10449 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10450 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10451 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10452 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10453 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10454 IF(SQC1.LT.1D-8) GOTO 230
10456 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10457 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10458 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10459 PHIR=PARU(2)*PYR(0)
10461 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10462 & SQRT(1D0-CTHE(2)**2)*CPHI
10464 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10465 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10466 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10467 & PMQ(3-JT)**2/SHP))
10468 ZMIN=2D0*PMQ(3-JT)/SHPR
10469 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10470 ZMAX=MIN(1D0-XH,ZMAX)
10471 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10475 ELSEIF(ISUB.EQ.10) THEN
10476 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10477 IF(MINT(2).EQ.1) THEN
10480 C...W exchange: need to mix flavours according to CKM matrix
10485 RVCKM=VINT(180+I)*PYR(0)
10488 IPM=(5-ISIGN(1,I))/2
10490 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10491 MINT(20+JT)=ISIGN(IB,I)
10492 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10493 IF(RVCKM.LE.0D0) GOTO 280
10496 IB=2*((IA+1)/2)-1+MOD(IA,2)
10497 MINT(20+JT)=ISIGN(IB,I)
10504 ELSEIF(ISUB.LE.20) THEN
10505 IF(ISUB.EQ.11) THEN
10506 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10508 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10510 ELSEIF(ISUB.EQ.12) THEN
10511 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10512 MINT(21)=ISIGN(KFLF,MINT(15))
10516 ELSEIF(ISUB.EQ.13) THEN
10517 C...f + fbar -> g + g; th arbitrary
10522 ELSEIF(ISUB.EQ.14) THEN
10523 C...f + fbar -> g + gamma; th arbitrary
10524 IF(PYR(0).GT.0.5D0) JS=2
10529 ELSEIF(ISUB.EQ.15) THEN
10530 C...f + fbar -> g + Z0; th arbitrary
10531 IF(PYR(0).GT.0.5D0) JS=2
10536 ELSEIF(ISUB.EQ.16) THEN
10537 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10538 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10539 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10540 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10542 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10545 ELSEIF(ISUB.EQ.17) THEN
10546 C...f + fbar -> g + h0; th arbitrary
10547 IF(PYR(0).GT.0.5D0) JS=2
10552 ELSEIF(ISUB.EQ.18) THEN
10553 C...f + fbar -> gamma + gamma; th arbitrary
10557 ELSEIF(ISUB.EQ.19) THEN
10558 C...f + fbar -> gamma + Z0; th arbitrary
10559 IF(PYR(0).GT.0.5D0) JS=2
10563 ELSEIF(ISUB.EQ.20) THEN
10564 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10565 C...(p(fbar')-p(W+))**2
10566 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10567 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10568 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10570 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10573 ELSEIF(ISUB.LE.30) THEN
10574 IF(ISUB.EQ.21) THEN
10575 C...f + fbar -> gamma + h0; th arbitrary
10576 IF(PYR(0).GT.0.5D0) JS=2
10580 ELSEIF(ISUB.EQ.22) THEN
10581 C...f + fbar -> Z0 + Z0; th arbitrary
10585 ELSEIF(ISUB.EQ.23) THEN
10586 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10587 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10588 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10589 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10591 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10593 ELSEIF(ISUB.EQ.24) THEN
10594 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10595 IF(PYR(0).GT.0.5D0) JS=2
10599 ELSEIF(ISUB.EQ.25) THEN
10600 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10601 MINT(21)=-ISIGN(24,MINT(15))
10604 ELSEIF(ISUB.EQ.26) THEN
10605 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10606 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10607 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10608 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10609 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10610 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10613 ELSEIF(ISUB.EQ.27) THEN
10614 C...f + fbar -> h0 + h0
10616 ELSEIF(ISUB.EQ.28) THEN
10617 C...f + g -> f + g; th = (p(f)-p(f))**2
10618 IF(MINT(15).EQ.21) JS=2
10620 IF(MINT(15).EQ.21) KCC=KCC+2
10621 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10622 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10624 ELSEIF(ISUB.EQ.29) THEN
10625 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10626 IF(MINT(15).EQ.21) JS=2
10629 KCS=ISIGN(1,MINT(14+JS))
10631 ELSEIF(ISUB.EQ.30) THEN
10632 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10633 IF(MINT(15).EQ.21) JS=2
10636 KCS=ISIGN(1,MINT(14+JS))
10639 ELSEIF(ISUB.LE.40) THEN
10640 IF(ISUB.EQ.31) THEN
10641 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10642 IF(MINT(15).EQ.21) JS=2
10645 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10646 RVCKM=VINT(180+I)*PYR(0)
10649 IPM=(5-ISIGN(1,I))/2
10651 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10652 MINT(20+JS)=ISIGN(IB,I)
10653 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10654 IF(RVCKM.LE.0D0) GOTO 300
10657 KCS=ISIGN(1,MINT(14+JS))
10659 ELSEIF(ISUB.EQ.32) THEN
10660 C...f + g -> f + h0; th = (p(f)-p(f))**2
10661 IF(MINT(15).EQ.21) JS=2
10664 KCS=ISIGN(1,MINT(14+JS))
10666 ELSEIF(ISUB.EQ.33) THEN
10667 C...f + gamma -> f + g; th=(p(f)-p(f))**2
10668 IF(MINT(15).EQ.22) JS=2
10671 KCS=ISIGN(1,MINT(14+JS))
10673 ELSEIF(ISUB.EQ.34) THEN
10674 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10675 IF(MINT(15).EQ.22) JS=2
10677 KCS=ISIGN(1,MINT(14+JS))
10679 ELSEIF(ISUB.EQ.35) THEN
10680 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10681 IF(MINT(15).EQ.22) JS=2
10685 ELSEIF(ISUB.EQ.36) THEN
10686 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10687 IF(MINT(15).EQ.22) JS=2
10690 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10692 RVCKM=VINT(180+I)*PYR(0)
10695 IPM=(5-ISIGN(1,I))/2
10697 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10698 MINT(20+JS)=ISIGN(IB,I)
10699 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10700 IF(RVCKM.LE.0D0) GOTO 320
10703 IB=2*((IA+1)/2)-1+MOD(IA,2)
10704 MINT(20+JS)=ISIGN(IB,I)
10708 ELSEIF(ISUB.EQ.37) THEN
10709 C...f + gamma -> f + h0
10711 ELSEIF(ISUB.EQ.38) THEN
10712 C...f + Z0 -> f + g
10714 ELSEIF(ISUB.EQ.39) THEN
10715 C...f + Z0 -> f + gamma
10717 ELSEIF(ISUB.EQ.40) THEN
10718 C...f + Z0 -> f + Z0
10721 ELSEIF(ISUB.LE.50) THEN
10722 IF(ISUB.EQ.41) THEN
10723 C...f + Z0 -> f' + W+/-
10725 ELSEIF(ISUB.EQ.42) THEN
10726 C...f + Z0 -> f + h0
10728 ELSEIF(ISUB.EQ.43) THEN
10729 C...f + W+/- -> f' + g
10731 ELSEIF(ISUB.EQ.44) THEN
10732 C...f + W+/- -> f' + gamma
10734 ELSEIF(ISUB.EQ.45) THEN
10735 C...f + W+/- -> f' + Z0
10737 ELSEIF(ISUB.EQ.46) THEN
10738 C...f + W+/- -> f' + W+/-
10740 ELSEIF(ISUB.EQ.47) THEN
10741 C...f + W+/- -> f' + h0
10743 ELSEIF(ISUB.EQ.48) THEN
10744 C...f + h0 -> f + g
10746 ELSEIF(ISUB.EQ.49) THEN
10747 C...f + h0 -> f + gamma
10749 ELSEIF(ISUB.EQ.50) THEN
10750 C...f + h0 -> f + Z0
10753 ELSEIF(ISUB.LE.60) THEN
10754 IF(ISUB.EQ.51) THEN
10755 C...f + h0 -> f' + W+/-
10757 ELSEIF(ISUB.EQ.52) THEN
10758 C...f + h0 -> f + h0
10760 ELSEIF(ISUB.EQ.53) THEN
10761 C...g + g -> f + fbar; th arbitrary
10762 KCS=(-1)**INT(1.5D0+PYR(0))
10763 MINT(21)=ISIGN(KFLF,KCS)
10767 ELSEIF(ISUB.EQ.54) THEN
10768 C...g + gamma -> f + fbar; th arbitrary
10769 KCS=(-1)**INT(1.5D0+PYR(0))
10770 MINT(21)=ISIGN(KFLF,KCS)
10773 IF(MINT(16).EQ.21) KCC=28
10775 ELSEIF(ISUB.EQ.55) THEN
10776 C...g + Z0 -> f + fbar
10778 ELSEIF(ISUB.EQ.56) THEN
10779 C...g + W+/- -> f + fbar'
10781 ELSEIF(ISUB.EQ.57) THEN
10782 C...g + h0 -> f + fbar
10784 ELSEIF(ISUB.EQ.58) THEN
10785 C...gamma + gamma -> f + fbar; th arbitrary
10786 KCS=(-1)**INT(1.5D0+PYR(0))
10787 MINT(21)=ISIGN(KFLF,KCS)
10791 ELSEIF(ISUB.EQ.59) THEN
10792 C...gamma + Z0 -> f + fbar
10794 ELSEIF(ISUB.EQ.60) THEN
10795 C...gamma + W+/- -> f + fbar'
10798 ELSEIF(ISUB.LE.70) THEN
10799 IF(ISUB.EQ.61) THEN
10800 C...gamma + h0 -> f + fbar
10802 ELSEIF(ISUB.EQ.62) THEN
10803 C...Z0 + Z0 -> f + fbar
10805 ELSEIF(ISUB.EQ.63) THEN
10806 C...Z0 + W+/- -> f + fbar'
10808 ELSEIF(ISUB.EQ.64) THEN
10809 C...Z0 + h0 -> f + fbar
10811 ELSEIF(ISUB.EQ.65) THEN
10812 C...W+ + W- -> f + fbar
10814 ELSEIF(ISUB.EQ.66) THEN
10815 C...W+/- + h0 -> f + fbar'
10817 ELSEIF(ISUB.EQ.67) THEN
10818 C...h0 + h0 -> f + fbar
10820 ELSEIF(ISUB.EQ.68) THEN
10821 C...g + g -> g + g; th arbitrary
10823 KCS=(-1)**INT(1.5D0+PYR(0))
10825 ELSEIF(ISUB.EQ.69) THEN
10826 C...gamma + gamma -> W+ + W-; th arbitrary
10831 ELSEIF(ISUB.EQ.70) THEN
10832 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10833 IF(MINT(15).EQ.22) MINT(21)=23
10834 IF(MINT(16).EQ.22) MINT(22)=23
10838 ELSEIF(ISUB.LE.80) THEN
10839 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10840 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10844 PMQ(1)=PYMASS(MINT(21))
10845 PMQ(2)=PYMASS(MINT(22))
10846 330 JT=INT(1.5D0+PYR(0))
10847 ZMIN=2D0*PMQ(JT)/SHPR
10848 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10849 & (SHPR*(SHPR-PMQ(3-JT)))
10850 ZMAX=MIN(1D0-XH,ZMAX)
10851 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10852 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10853 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10854 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10855 IF(SQC1.LT.1D-8) GOTO 330
10857 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10858 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10859 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10860 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10861 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10862 IF(SQC1.LT.1D-8) GOTO 330
10864 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10865 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10866 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10867 PHIR=PARU(2)*PYR(0)
10869 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10870 & SQRT(1D0-CTHE(2)**2)*CPHI
10872 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10873 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10874 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10875 & PMQ(3-JT)**2/SHP))
10876 ZMIN=2D0*PMQ(3-JT)/SHPR
10877 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10878 ZMAX=MIN(1D0-XH,ZMAX)
10879 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10882 ELSEIF(ISUB.EQ.73) THEN
10883 C...Z0 + W+/- -> Z0 + W+/-
10890 RVCKM=VINT(180+I)*PYR(0)
10893 IPM=(5-ISIGN(1,I))/2
10895 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10896 MINT(20+JT)=ISIGN(IB,I)
10897 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10898 IF(RVCKM.LE.0D0) GOTO 360
10901 IB=2*((IA+1)/2)-1+MOD(IA,2)
10902 MINT(20+JT)=ISIGN(IB,I)
10904 360 PMQ(JT)=PYMASS(MINT(20+JT))
10905 MINT(23-JT)=MINT(17-JT)
10906 PMQ(3-JT)=PYMASS(MINT(23-JT))
10907 JT=INT(1.5D0+PYR(0))
10908 ZMIN=2D0*PMQ(JT)/SHPR
10909 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10910 & (SHPR*(SHPR-PMQ(3-JT)))
10911 ZMAX=MIN(1D0-XH,ZMAX)
10912 IF(ZMIN.GE.ZMAX) GOTO 340
10913 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10914 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10915 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10916 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10917 IF(SQC1.LT.1D-8) GOTO 340
10919 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10920 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10921 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10922 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10923 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10924 IF(SQC1.LT.1D-8) GOTO 340
10926 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10927 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10928 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10929 PHIR=PARU(2)*PYR(0)
10931 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10932 & SQRT(1D0-CTHE(2)**2)*CPHI
10934 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10935 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10936 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10937 & PMQ(3-JT)**2/SHP))
10938 ZMIN=2D0*PMQ(3-JT)/SHPR
10939 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10940 ZMAX=MIN(1D0-XH,ZMAX)
10941 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10944 ELSEIF(ISUB.EQ.74) THEN
10945 C...Z0 + h0 -> Z0 + h0
10947 ELSEIF(ISUB.EQ.75) THEN
10948 C...W+ + W- -> gamma + gamma
10950 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10951 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10957 RVCKM=VINT(180+I)*PYR(0)
10960 IPM=(5-ISIGN(1,I))/2
10962 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10963 MINT(20+JT)=ISIGN(IB,I)
10964 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10965 IF(RVCKM.LE.0D0) GOTO 390
10968 IB=2*((IA+1)/2)-1+MOD(IA,2)
10969 MINT(20+JT)=ISIGN(IB,I)
10971 390 PMQ(JT)=PYMASS(MINT(20+JT))
10973 JT=INT(1.5D0+PYR(0))
10974 ZMIN=2D0*PMQ(JT)/SHPR
10975 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10976 & (SHPR*(SHPR-PMQ(3-JT)))
10977 ZMAX=MIN(1D0-XH,ZMAX)
10978 IF(ZMIN.GE.ZMAX) GOTO 370
10979 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10980 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10981 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10982 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10983 IF(SQC1.LT.1D-8) GOTO 370
10985 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10986 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10987 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10988 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10989 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10990 IF(SQC1.LT.1D-8) GOTO 370
10992 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10993 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10994 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10995 PHIR=PARU(2)*PYR(0)
10997 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10998 & SQRT(1D0-CTHE(2)**2)*CPHI
11000 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11001 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11002 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11003 & PMQ(3-JT)**2/SHP))
11004 ZMIN=2D0*PMQ(3-JT)/SHPR
11005 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11006 ZMAX=MIN(1D0-XH,ZMAX)
11007 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11010 ELSEIF(ISUB.EQ.78) THEN
11011 C...W+/- + h0 -> W+/- + h0
11013 ELSEIF(ISUB.EQ.79) THEN
11014 C...h0 + h0 -> h0 + h0
11016 ELSEIF(ISUB.EQ.80) THEN
11017 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11018 IF(MINT(15).EQ.22) JS=2
11021 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11023 MINT(20+JS)=ISIGN(IB,I)
11027 ELSEIF(ISUB.LE.90) THEN
11028 IF(ISUB.EQ.81) THEN
11029 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11030 MINT(21)=ISIGN(MINT(55),MINT(15))
11034 ELSEIF(ISUB.EQ.82) THEN
11035 C...g + g -> Q + Qbar; th arbitrary
11036 KCS=(-1)**INT(1.5D0+PYR(0))
11037 MINT(21)=ISIGN(MINT(55),KCS)
11041 ELSEIF(ISUB.EQ.83) THEN
11042 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11044 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11046 IF(KFAOLD.GT.10) THEN
11047 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11049 RCKM=VINT(180+KFOLD)*PYR(0)
11050 IPM=(5-ISIGN(1,KFOLD))/2
11051 KFANEW=-MOD(KFAOLD+1,2)
11052 410 KFANEW=KFANEW+2
11053 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11054 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11055 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11056 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11057 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11058 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11060 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11062 IF(MINT(2).EQ.1) THEN
11063 MINT(21)=ISIGN(MINT(55),MINT(15))
11064 MINT(22)=ISIGN(KFANEW,MINT(16))
11066 MINT(21)=ISIGN(KFANEW,MINT(15))
11067 MINT(22)=ISIGN(MINT(55),MINT(16))
11072 ELSEIF(ISUB.EQ.84) THEN
11073 C...g + gamma -> Q + Qbar; th arbitary
11074 KCS=(-1)**INT(1.5D0+PYR(0))
11075 MINT(21)=ISIGN(MINT(55),KCS)
11078 IF(MINT(16).EQ.21) KCC=28
11080 ELSEIF(ISUB.EQ.85) THEN
11081 C...gamma + gamma -> F + Fbar; th arbitary
11082 KCS=(-1)**INT(1.5D0+PYR(0))
11083 MINT(21)=ISIGN(MINT(56),KCS)
11087 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11088 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11089 MINT(21)=KFPR(ISUB,1)
11090 MINT(22)=KFPR(ISUB,2)
11092 KCS=(-1)**INT(1.5D0+PYR(0))
11095 ELSEIF(ISUB.LE.100) THEN
11096 IF(ISUB.EQ.95) THEN
11097 C...Low-pT ( = energyless g + g -> g + g)
11099 KCS=(-1)**INT(1.5D0+PYR(0))
11101 ELSEIF(ISUB.EQ.96) THEN
11102 C...Multiple interactions (should be reassigned to QCD process)
11105 ELSEIF(ISUB.LE.110) THEN
11106 IF(ISUB.EQ.101) THEN
11107 C...g + g -> gamma*/Z0
11111 ELSEIF(ISUB.EQ.102) THEN
11112 C...g + g -> h0 (or H0, or A0)
11116 ELSEIF(ISUB.EQ.103) THEN
11117 C...gamma + gamma -> h0 (or H0, or A0)
11121 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11122 C...g + g -> chi_0c or chi_2c.
11126 ELSEIF(ISUB.EQ.106) THEN
11127 C...g + g -> J/Psi + gamma
11128 MINT(21)=KFPR(ISUB,1)
11129 MINT(22)=KFPR(ISUB,2)
11132 ELSEIF(ISUB.EQ.107) THEN
11133 C...g + gamma -> J/Psi + g
11134 MINT(21)=KFPR(ISUB,1)
11135 MINT(22)=KFPR(ISUB,2)
11137 IF(MINT(16).EQ.22) KCC=33
11139 ELSEIF(ISUB.EQ.108) THEN
11140 C...gamma + gamma -> J/Psi + gamma
11141 MINT(21)=KFPR(ISUB,1)
11142 MINT(22)=KFPR(ISUB,2)
11144 ELSEIF(ISUB.EQ.110) THEN
11145 C...f + fbar -> gamma + h0; th arbitrary
11146 IF(PYR(0).GT.0.5D0) JS=2
11151 ELSEIF(ISUB.LE.120) THEN
11152 IF(ISUB.EQ.111) THEN
11153 C...f + fbar -> g + h0; th arbitrary
11154 IF(PYR(0).GT.0.5D0) JS=2
11159 ELSEIF(ISUB.EQ.112) THEN
11160 C...f + g -> f + h0; th = (p(f) - p(f))**2
11161 IF(MINT(15).EQ.21) JS=2
11164 KCS=ISIGN(1,MINT(14+JS))
11166 ELSEIF(ISUB.EQ.113) THEN
11167 C...g + g -> g + h0; th arbitrary
11168 IF(PYR(0).GT.0.5D0) JS=2
11171 KCS=(-1)**INT(1.5D0+PYR(0))
11173 ELSEIF(ISUB.EQ.114) THEN
11174 C...g + g -> gamma + gamma; th arbitrary
11175 IF(PYR(0).GT.0.5D0) JS=2
11180 ELSEIF(ISUB.EQ.115) THEN
11181 C...g + g -> g + gamma; th arbitrary
11182 IF(PYR(0).GT.0.5D0) JS=2
11185 KCS=(-1)**INT(1.5D0+PYR(0))
11187 ELSEIF(ISUB.EQ.116) THEN
11188 C...g + g -> gamma + Z0
11190 ELSEIF(ISUB.EQ.117) THEN
11191 C...g + g -> Z0 + Z0
11193 ELSEIF(ISUB.EQ.118) THEN
11194 C...g + g -> W+ + W-
11197 ELSEIF(ISUB.LE.140) THEN
11198 IF(ISUB.EQ.121) THEN
11199 C...g + g -> Q + Qbar + h0
11200 KCS=(-1)**INT(1.5D0+PYR(0))
11201 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11203 KCC=11+INT(0.5D0+PYR(0))
11206 ELSEIF(ISUB.EQ.122) THEN
11207 C...q + qbar -> Q + Qbar + h0
11208 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11213 ELSEIF(ISUB.EQ.123) THEN
11214 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11219 ELSEIF(ISUB.EQ.124) THEN
11220 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11226 RVCKM=VINT(180+I)*PYR(0)
11229 IPM=(5-ISIGN(1,I))/2
11231 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11232 MINT(20+JT)=ISIGN(IB,I)
11233 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11234 IF(RVCKM.LE.0D0) GOTO 430
11237 IB=2*((IA+1)/2)-1+MOD(IA,2)
11238 MINT(20+JT)=ISIGN(IB,I)
11244 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11245 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11246 IF(MINT(15).EQ.22) JS=2
11249 KCS=ISIGN(1,MINT(14+JS))
11251 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11252 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11253 IF(MINT(15).EQ.22) JS=2
11255 KCS=ISIGN(1,MINT(14+JS))
11257 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11258 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11259 KCS=(-1)**INT(1.5D0+PYR(0))
11260 MINT(21)=ISIGN(KFLF,KCS)
11263 IF(MINT(16).EQ.21) KCC=28
11265 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11266 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11267 KCS=(-1)**INT(1.5D0+PYR(0))
11268 MINT(21)=ISIGN(KFLF,KCS)
11274 ELSEIF(ISUB.LE.160) THEN
11275 IF(ISUB.EQ.141) THEN
11276 C...f + fbar -> gamma*/Z0/Z'0
11279 ELSEIF(ISUB.EQ.142) THEN
11280 C...f + fbar' -> W'+/-
11281 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11282 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11283 KFRES=ISIGN(34,KCH1+KCH2)
11285 ELSEIF(ISUB.EQ.143) THEN
11286 C...f + fbar' -> H+/-
11287 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11288 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11289 KFRES=ISIGN(37,KCH1+KCH2)
11291 ELSEIF(ISUB.EQ.144) THEN
11293 KFRES=ISIGN(41,MINT(15)+MINT(16))
11295 ELSEIF(ISUB.EQ.145) THEN
11296 C...q + l -> LQ (leptoquark)
11297 IF(IABS(MINT(16)).LE.8) JS=2
11298 KFRES=ISIGN(42,MINT(14+JS))
11300 KCS=ISIGN(1,MINT(14+JS))
11302 ELSEIF(ISUB.EQ.146) THEN
11303 C...e + gamma -> e* (excited lepton)
11304 IF(MINT(15).EQ.22) JS=2
11305 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11308 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11309 C...q + g -> q* (excited quark)
11310 IF(MINT(15).EQ.21) JS=2
11311 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11313 KCS=ISIGN(1,MINT(14+JS))
11315 ELSEIF(ISUB.EQ.149) THEN
11316 C...g + g -> eta_tc
11319 KCS=(-1)**INT(1.5D0+PYR(0))
11322 ELSEIF(ISUB.LE.200) THEN
11323 IF(ISUB.EQ.161) THEN
11324 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11325 IF(MINT(15).EQ.21) JS=2
11328 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11329 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11330 MINT(20+JS)=ISIGN(IB,I)
11332 KCS=ISIGN(1,MINT(14+JS))
11334 ELSEIF(ISUB.EQ.162) THEN
11335 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11336 IF(MINT(15).EQ.21) JS=2
11337 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11338 KFLQL=KFDP(MDCY(42,2),2)
11339 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11341 KCS=ISIGN(1,MINT(14+JS))
11343 ELSEIF(ISUB.EQ.163) THEN
11344 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11345 KCS=(-1)**INT(1.5D0+PYR(0))
11346 MINT(21)=ISIGN(42,KCS)
11350 ELSEIF(ISUB.EQ.164) THEN
11351 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11352 MINT(21)=ISIGN(42,MINT(15))
11356 ELSEIF(ISUB.EQ.165) THEN
11357 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11358 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11361 ELSEIF(ISUB.EQ.166) THEN
11362 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11363 IF(MOD(MINT(15),2).EQ.0) THEN
11364 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11365 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11367 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11368 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11371 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11372 C...q + q' -> q" + q* (excited quark)
11373 KFQSTR=KFPR(ISUB,2)
11374 KFQEXC=MOD(KFQSTR,KEXCIT)
11376 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11377 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11378 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11382 ELSEIF(ISUB.EQ.169) THEN
11383 C...q + qbar -> e + e* (excited lepton)
11384 KFQSTR=KFPR(ISUB,2)
11385 KFQEXC=MOD(KFQSTR,KEXCIT)
11387 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11388 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11391 ELSEIF(ISUB.EQ.191) THEN
11392 C...f + fbar -> rho_tc0.
11395 ELSEIF(ISUB.EQ.192) THEN
11396 C...f + fbar' -> rho_tc+/-
11397 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11398 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11399 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11401 ELSEIF(ISUB.EQ.193) THEN
11402 C...f + fbar -> omega_tc0.
11405 ELSEIF(ISUB.EQ.194) THEN
11406 C...f + fbar -> f' + fbar' via mixture of s-channel
11407 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11408 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11411 ELSEIF(ISUB.EQ.195) THEN
11412 C...f + fbar' -> f'' + fbar''' via s-channel
11413 C...rho_tc+ th=(p(f)-p(f'))**2
11414 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11415 IF(MOD(MINT(15),2).EQ.0) THEN
11416 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11417 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11419 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11420 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11425 ELSEIF(ISUB.LE.215) THEN
11426 IF(ISUB.EQ.201) THEN
11427 C...f + fbar -> ~e_L + ~e_Lbar
11428 MINT(21)=ISIGN(KSUSY1+11,KCS)
11431 ELSEIF(ISUB.EQ.202) THEN
11432 C...f + fbar -> ~e_R + ~e_Rbar
11433 MINT(21)=ISIGN(KSUSY2+11,KCS)
11436 ELSEIF(ISUB.EQ.203) THEN
11437 C...f + fbar -> ~e_L + ~e_Rbar
11438 IF(MINT(15).LT.0) JS=2
11439 IF(MINT(2).EQ.1) THEN
11440 MINT(20+JS)=KFPR(ISUB,1)
11441 MINT(23-JS)=-KFPR(ISUB,2)
11443 MINT(20+JS)=-KFPR(ISUB,1)
11444 MINT(23-JS)=KFPR(ISUB,2)
11447 ELSEIF(ISUB.EQ.204) THEN
11448 C...f + fbar -> ~mu_L + ~mu_Lbar
11449 MINT(21)=ISIGN(KSUSY1+13,KCS)
11452 ELSEIF(ISUB.EQ.205) THEN
11453 C...f + fbar -> ~mu_R + ~mu_Rbar
11454 MINT(21)=ISIGN(KSUSY2+13,KCS)
11457 ELSEIF(ISUB.EQ.206) THEN
11458 C...f + fbar -> ~mu_L + ~mu_Rbar
11459 IF(MINT(15).LT.0) JS=2
11460 IF(MINT(2).EQ.1) THEN
11461 MINT(20+JS)=KFPR(ISUB,1)
11462 MINT(23-JS)=-KFPR(ISUB,2)
11464 MINT(20+JS)=-KFPR(ISUB,1)
11465 MINT(23-JS)=KFPR(ISUB,2)
11468 ELSEIF(ISUB.EQ.207) THEN
11469 C...f + fbar -> ~tau_1 + ~tau_1bar
11470 MINT(21)=ISIGN(KSUSY1+15,KCS)
11473 ELSEIF(ISUB.EQ.208) THEN
11474 C...f + fbar -> ~tau_2 + ~tau_2bar
11475 MINT(21)=ISIGN(KSUSY2+15,KCS)
11478 ELSEIF(ISUB.EQ.209) THEN
11479 C...f + fbar -> ~tau_1 + ~tau_2bar
11480 IF(MINT(15).LT.0) JS=2
11481 IF(MINT(2).EQ.1) THEN
11482 MINT(20+JS)=KFPR(ISUB,1)
11483 MINT(23-JS)=-KFPR(ISUB,2)
11485 MINT(20+JS)=-KFPR(ISUB,1)
11486 MINT(23-JS)=KFPR(ISUB,2)
11489 ELSEIF(ISUB.EQ.210) THEN
11490 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11491 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11492 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11493 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11494 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11496 ELSEIF(ISUB.EQ.211) THEN
11497 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11498 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11499 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11500 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11501 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11503 ELSEIF(ISUB.EQ.212) THEN
11504 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11505 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11506 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11507 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11508 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11510 ELSEIF(ISUB.EQ.213) THEN
11511 C...f + fbar -> ~nul + ~nulbar
11512 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11515 ELSEIF(ISUB.EQ.214) THEN
11516 C...f + fbar -> ~nutau + ~nutaubar
11517 MINT(21)=ISIGN(KSUSY1+16,KCS)
11521 ELSEIF(ISUB.LE.225) THEN
11522 IF(ISUB.EQ.216) THEN
11523 C...f + fbar -> ~chi01 + ~chi01
11527 ELSEIF(ISUB.EQ.217) THEN
11528 C...f + fbar -> ~chi02 + ~chi02
11532 ELSEIF(ISUB.EQ.218 ) THEN
11533 C...f + fbar -> ~chi03 + ~chi03
11537 ELSEIF(ISUB.EQ.219 ) THEN
11538 C...f + fbar -> ~chi04 + ~chi04
11542 ELSEIF(ISUB.EQ.220 ) THEN
11543 C...f + fbar -> ~chi01 + ~chi02
11544 IF(MINT(15).LT.0) JS=2
11545 C IF(PYR(0).GT.0.5D0) JS=2
11546 MINT(20+JS)=KSUSY1+22
11547 MINT(23-JS)=KSUSY1+23
11549 ELSEIF(ISUB.EQ.221 ) THEN
11550 C...f + fbar -> ~chi01 + ~chi03
11551 IF(MINT(15).LT.0) JS=2
11552 C IF(PYR(0).GT.0.5D0) JS=2
11553 MINT(20+JS)=KSUSY1+22
11554 MINT(23-JS)=KSUSY1+25
11556 ELSEIF(ISUB.EQ.222) THEN
11557 C...f + fbar -> ~chi01 + ~chi04
11558 IF(MINT(15).LT.0) JS=2
11559 C IF(PYR(0).GT.0.5D0) JS=2
11560 MINT(20+JS)=KSUSY1+22
11561 MINT(23-JS)=KSUSY1+35
11563 ELSEIF(ISUB.EQ.223) THEN
11564 C...f + fbar -> ~chi02 + ~chi03
11565 IF(MINT(15).LT.0) JS=2
11566 C IF(PYR(0).GT.0.5D0) JS=2
11567 MINT(20+JS)=KSUSY1+23
11568 MINT(23-JS)=KSUSY1+25
11570 ELSEIF(ISUB.EQ.224) THEN
11571 C...f + fbar -> ~chi02 + ~chi04
11572 IF(MINT(15).LT.0) JS=2
11573 C IF(PYR(0).GT.0.5D0) JS=2
11574 MINT(20+JS)=KSUSY1+23
11575 MINT(23-JS)=KSUSY1+35
11577 ELSEIF(ISUB.EQ.225) THEN
11578 C...f + fbar -> ~chi03 + ~chi04
11579 IF(MINT(15).LT.0) JS=2
11580 C IF(PYR(0).GT.0.5D0) JS=2
11581 MINT(20+JS)=KSUSY1+25
11582 MINT(23-JS)=KSUSY1+35
11585 ELSEIF(ISUB.LE.236) THEN
11586 IF(ISUB.EQ.226) THEN
11587 C...f + fbar -> ~chi+-1 + ~chi-+1
11588 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11589 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11590 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11593 ELSEIF(ISUB.EQ.227) THEN
11594 C...f + fbar -> ~chi+-2 + ~chi-+2
11595 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11596 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11599 ELSEIF(ISUB.EQ.228) THEN
11600 C...f + fbar -> ~chi+-1 + ~chi-+2
11601 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11602 C...js=1 if pyr<.5, js=2 if pyr>.5
11603 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11604 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11605 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11606 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11607 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11609 IF(MINT(2).EQ.1) THEN
11610 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11611 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11612 c IF(KCH2.EQ.0) JS=2
11614 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11615 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11617 c IF(KCH2.EQ.1) JS=2
11620 ELSEIF(ISUB.EQ.229) THEN
11621 C...q + qbar' -> ~chi01 + ~chi+-1
11622 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11623 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11624 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11626 IF(MOD(MINT(15),2).EQ.0) JS=2
11627 MINT(20+JS)=KSUSY1+22
11628 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11630 ELSEIF(ISUB.EQ.230) THEN
11631 C...q + qbar' -> ~chi02 + ~chi+-1
11632 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11633 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11634 IF(MOD(MINT(15),2).EQ.0) JS=2
11635 MINT(20+JS)=KSUSY1+23
11636 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11638 ELSEIF(ISUB.EQ.231) THEN
11639 C...q + qbar' -> ~chi03 + ~chi+-1
11640 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11641 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11642 IF(MOD(MINT(15),2).EQ.0) JS=2
11643 MINT(20+JS)=KSUSY1+25
11644 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11646 ELSEIF(ISUB.EQ.232) THEN
11647 C...q + qbar' -> ~chi04 + ~chi+-1
11648 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11649 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11650 IF(MOD(MINT(15),2).EQ.0) JS=2
11651 MINT(20+JS)=KSUSY1+35
11652 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11654 ELSEIF(ISUB.EQ.233) THEN
11655 C...q + qbar' -> ~chi01 + ~chi+-2
11656 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11657 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11658 IF(MOD(MINT(15),2).EQ.0) JS=2
11659 MINT(20+JS)=KSUSY1+22
11660 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11662 ELSEIF(ISUB.EQ.234) THEN
11663 C...q + qbar' -> ~chi02 + ~chi+-2
11664 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11665 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11666 IF(MOD(MINT(15),2).EQ.0) JS=2
11667 MINT(20+JS)=KSUSY1+23
11668 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11670 ELSEIF(ISUB.EQ.235) THEN
11671 C...q + qbar' -> ~chi03 + ~chi+-2
11672 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11673 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11674 IF(MOD(MINT(15),2).EQ.0) JS=2
11675 MINT(20+JS)=KSUSY1+25
11676 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11678 ELSEIF(ISUB.EQ.236) THEN
11679 C...q + qbar' -> ~chi04 + ~chi+-2
11680 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11681 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11682 IF(MOD(MINT(15),2).EQ.0) JS=2
11683 MINT(20+JS)=KSUSY1+35
11684 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11687 ELSEIF(ISUB.LE.245) THEN
11688 IF(ISUB.EQ.237) THEN
11689 C...q + qbar -> ~chi01 + ~g
11691 IF(PYR(0).GT.0.5D0) JS=2
11692 MINT(20+JS)=KSUSY1+21
11693 MINT(23-JS)=KSUSY1+22
11696 ELSEIF(ISUB.EQ.238) THEN
11697 C...q + qbar -> ~chi02 + ~g
11699 IF(PYR(0).GT.0.5D0) JS=2
11700 MINT(20+JS)=KSUSY1+21
11701 MINT(23-JS)=KSUSY1+23
11704 ELSEIF(ISUB.EQ.239) THEN
11705 C...q + qbar -> ~chi03 + ~g
11707 IF(PYR(0).GT.0.5D0) JS=2
11708 MINT(20+JS)=KSUSY1+21
11709 MINT(23-JS)=KSUSY1+25
11712 ELSEIF(ISUB.EQ.240) THEN
11713 C...q + qbar -> ~chi04 + ~g
11715 IF(PYR(0).GT.0.5D0) JS=2
11716 MINT(20+JS)=KSUSY1+21
11717 MINT(23-JS)=KSUSY1+35
11720 ELSEIF(ISUB.EQ.241) THEN
11721 C...q + qbar' -> ~chi+-1 + ~g
11722 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11723 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11724 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11725 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11726 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11727 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11728 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11730 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11731 MINT(20+JS)=KSUSY1+21
11732 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11735 ELSEIF(ISUB.EQ.242) THEN
11736 C...q + qbar' -> ~chi+-2 + ~g
11737 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11738 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11739 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11740 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11741 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11742 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11743 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11745 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11746 MINT(20+JS)=KSUSY1+21
11747 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11750 ELSEIF(ISUB.EQ.243) THEN
11751 C...q + qbar -> ~g + ~g ; th arbitrary
11756 ELSEIF(ISUB.EQ.244) THEN
11757 C...g + g -> ~g + ~g ; th arbitrary
11759 KCS=(-1)**INT(1.5D0+PYR(0))
11764 ELSEIF(ISUB.LE.260) THEN
11765 IF(ISUB.EQ.246) THEN
11766 C...qj + g -> ~qj_L + ~chi01
11767 IF(MINT(15).EQ.21) JS=2
11770 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11771 MINT(23-JS)=KSUSY1+22
11773 KCS=ISIGN(1,MINT(14+JS))
11775 ELSEIF(ISUB.EQ.247) THEN
11776 C...qj + g -> ~qj_R + ~chi01
11777 IF(MINT(15).EQ.21) JS=2
11780 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11781 MINT(23-JS)=KSUSY1+22
11783 KCS=ISIGN(1,MINT(14+JS))
11785 ELSEIF(ISUB.EQ.248) THEN
11786 C...qj + g -> ~qj_L + ~chi02
11787 IF(MINT(15).EQ.21) JS=2
11790 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11791 MINT(23-JS)=KSUSY1+23
11793 KCS=ISIGN(1,MINT(14+JS))
11795 ELSEIF(ISUB.EQ.249) THEN
11796 C...qj + g -> ~qj_R + ~chi02
11797 IF(MINT(15).EQ.21) JS=2
11800 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11801 MINT(23-JS)=KSUSY1+23
11803 KCS=ISIGN(1,MINT(14+JS))
11805 ELSEIF(ISUB.EQ.250) THEN
11806 C...qj + g -> ~qj_L + ~chi03
11807 IF(MINT(15).EQ.21) JS=2
11810 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11811 MINT(23-JS)=KSUSY1+25
11813 KCS=ISIGN(1,MINT(14+JS))
11815 ELSEIF(ISUB.EQ.251) THEN
11816 C...qj + g -> ~qj_R + ~chi03
11817 IF(MINT(15).EQ.21) JS=2
11820 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11821 MINT(23-JS)=KSUSY1+25
11823 KCS=ISIGN(1,MINT(14+JS))
11825 ELSEIF(ISUB.EQ.252) THEN
11826 C...qj + g -> ~qj_L + ~chi04
11827 IF(MINT(15).EQ.21) JS=2
11830 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11831 MINT(23-JS)=KSUSY1+35
11833 KCS=ISIGN(1,MINT(14+JS))
11835 ELSEIF(ISUB.EQ.253) THEN
11836 C...qj + g -> ~qj_R + ~chi04
11837 IF(MINT(15).EQ.21) JS=2
11840 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11841 MINT(23-JS)=KSUSY1+35
11843 KCS=ISIGN(1,MINT(14+JS))
11845 ELSEIF(ISUB.EQ.254) THEN
11846 C...qj + g -> ~qk_L + ~chi+-1
11847 IF(MINT(15).EQ.21) JS=2
11850 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11851 IB=-IA+INT((IA+1)/2)*4-1
11852 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11854 KCS=ISIGN(1,MINT(14+JS))
11856 ELSEIF(ISUB.EQ.255) THEN
11857 C...qj + g -> ~qk_L + ~chi+-1
11858 IF(MINT(15).EQ.21) JS=2
11861 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11862 IB=-IA+INT((IA+1)/2)*4-1
11863 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11865 KCS=ISIGN(1,MINT(14+JS))
11867 ELSEIF(ISUB.EQ.256) THEN
11868 C...qj + g -> ~qk_L + ~chi+-2
11869 IF(MINT(15).EQ.21) JS=2
11872 IB=-IA+INT((IA+1)/2)*4-1
11873 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11874 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11876 KCS=ISIGN(1,MINT(14+JS))
11878 ELSEIF(ISUB.EQ.257) THEN
11879 C...qj + g -> ~qk_R + ~chi+-2
11880 IF(MINT(15).EQ.21) JS=2
11883 IB=-IA+INT((IA+1)/2)*4-1
11884 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11885 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11887 KCS=ISIGN(1,MINT(14+JS))
11889 ELSEIF(ISUB.EQ.258) THEN
11890 C...qj + g -> ~qj_L + ~g
11891 IF(MINT(15).EQ.21) JS=2
11894 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11895 MINT(23-JS)=KSUSY1+21
11897 IF(JS.EQ.2) KCC=KCC+2
11900 ELSEIF(ISUB.EQ.259) THEN
11901 C...qj + g -> ~qj_R + ~g
11902 IF(MINT(15).EQ.21) JS=2
11905 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11906 MINT(23-JS)=KSUSY1+21
11908 IF(JS.EQ.2) KCC=KCC+2
11912 ELSEIF(ISUB.LE.270) THEN
11913 IF(ISUB.EQ.261) THEN
11914 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11916 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11917 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11919 C...Correct color combination
11920 IF(MINT(43).EQ.4) KCC=4
11922 ELSEIF(ISUB.EQ.262) THEN
11923 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11925 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11926 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11928 C...Correct color combination
11929 IF(MINT(43).EQ.4) KCC=4
11931 ELSEIF(ISUB.EQ.263) THEN
11932 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11933 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11934 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11935 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11936 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11939 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11940 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11942 C...Correct color combination
11943 IF(MINT(43).EQ.4) KCC=4
11945 ELSEIF(ISUB.EQ.264) THEN
11946 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11947 KCS=(-1)**INT(1.5D0+PYR(0))
11948 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11952 ELSEIF(ISUB.EQ.265) THEN
11953 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11954 KCS=(-1)**INT(1.5D0+PYR(0))
11955 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11960 ELSEIF(ISUB.LE.296) THEN
11961 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11962 C...qi + qj -> ~qi_L + ~qj_L
11964 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11965 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11966 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11968 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11969 C...qi + qj -> ~qi_R + ~qj_R
11971 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11972 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11973 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11975 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11976 C...qi + qj -> ~qi_L + ~qj_R
11977 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11978 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11980 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11982 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11983 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11984 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11985 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11987 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11989 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11990 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11991 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11992 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11994 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11996 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
11997 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11998 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11999 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12001 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12003 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12004 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12006 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12007 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12009 IF(MINT(43).EQ.4) KCC=4
12011 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12012 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12014 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12015 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12017 IF(MINT(43).EQ.4) KCC=4
12019 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12020 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12022 KCS=(-1)**INT(1.5D0+PYR(0))
12023 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12027 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12028 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12029 KCS=(-1)**INT(1.5D0+PYR(0))
12030 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12034 ELSEIF(ISUB.EQ.294) THEN
12035 C...qj + g -> ~qj_L + ~g
12036 IF(MINT(15).EQ.21) JS=2
12039 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12040 MINT(23-JS)=KSUSY1+21
12042 IF(JS.EQ.2) KCC=KCC+2
12045 ELSEIF(ISUB.EQ.295) THEN
12046 C...qj + g -> ~qj_R + ~g
12047 IF(MINT(15).EQ.21) JS=2
12050 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12051 MINT(23-JS)=KSUSY1+21
12053 IF(JS.EQ.2) KCC=KCC+2
12057 ELSEIF(ISUB.LE.340) THEN
12059 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12060 C...q + qbar' -> H+ + H0
12061 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12062 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12063 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12064 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12065 MINT(23-JS)=KFPR(ISUB,2)
12066 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12067 C...f + fbar -> A0 + H0; th arbitrary
12068 IF(PYR(0).GT.0.5D0) JS=2
12069 MINT(20+JS)=KFPR(ISUB,1)
12070 MINT(23-JS)=KFPR(ISUB,2)
12071 ELSEIF(ISUB.EQ.301) THEN
12072 C...f + fbar -> H+ H-
12073 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12078 ELSEIF(ISUB.LE.360) THEN
12080 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12081 C...l + l -> H_L++/--, H_R++/--
12082 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12083 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12084 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12086 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12087 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12088 IF(MINT(15).EQ.22) JS=2
12089 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12090 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12093 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12094 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12095 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12098 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12099 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12100 C...as inner process).
12105 RVCKM=VINT(180+I)*PYR(0)
12108 IPM=(5-ISIGN(1,I))/2
12110 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12111 MINT(20+JT)=ISIGN(IB,I)
12112 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12113 IF(RVCKM.LE.0D0) GOTO 450
12116 IB=2*((IA+1)/2)-1+MOD(IA,2)
12117 MINT(20+JT)=ISIGN(IB,I)
12121 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12122 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12124 ELSEIF(ISUB.EQ.353) THEN
12125 C...f + fbar -> Z_R0
12128 ELSEIF(ISUB.EQ.354) THEN
12129 C...f + fbar' -> W+/-
12130 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12131 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12132 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12136 ELSEIF(ISUB.LE.380) THEN
12138 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12139 C...f + fbar -> charged+ charged- technicolor
12140 KSW=(-1)**INT(1.5D0+PYR(0))
12141 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12142 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12144 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12145 C...f + fbar -> neutral neutral technicolor
12146 MINT(21)=KFPR(ISUB,1)
12147 MINT(22)=KFPR(ISUB,2)
12149 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12150 C...f + fbar' -> neutral charged technicolor
12153 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12154 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12155 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12156 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12157 MINT(20+JS)=KFPR(ISUB,IN)
12159 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12160 C...f + fbar' -> charged neutral technicolor
12163 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12164 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12165 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12166 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12167 MINT(23-JS)=KFPR(ISUB,IN)
12170 ELSEIF(ISUB.LE.400) THEN
12171 IF(ISUB.EQ.381) THEN
12172 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12174 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12176 ELSEIF(ISUB.EQ.382) THEN
12177 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12178 MINT(21)=ISIGN(KFLF,MINT(15))
12182 ELSEIF(ISUB.EQ.383) THEN
12183 C...f + fbar -> g + g; th arbitrary, TC extensions
12188 ELSEIF(ISUB.EQ.384) THEN
12189 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12190 IF(MINT(15).EQ.21) JS=2
12192 IF(MINT(15).EQ.21) KCC=KCC+2
12193 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12194 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12196 ELSEIF(ISUB.EQ.385) THEN
12197 C...g + g -> f + fbar; th arbitrary, TC extensions
12198 KCS=(-1)**INT(1.5D0+PYR(0))
12199 MINT(21)=ISIGN(KFLF,KCS)
12203 ELSEIF(ISUB.EQ.386) THEN
12204 C...g + g -> g + g; th arbitrary, TC extensions
12206 KCS=(-1)**INT(1.5D0+PYR(0))
12208 ELSEIF(ISUB.EQ.387) THEN
12209 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12210 MINT(21)=ISIGN(MINT(55),MINT(15))
12214 ELSEIF(ISUB.EQ.388) THEN
12215 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12216 KCS=(-1)**INT(1.5D0+PYR(0))
12217 MINT(21)=ISIGN(MINT(55),KCS)
12221 ELSEIF(ISUB.EQ.391) THEN
12222 C...f + fbar -> G*.
12225 ELSEIF(ISUB.EQ.392) THEN
12230 ELSEIF(ISUB.EQ.393) THEN
12231 C...q + qbar -> g + G*; th arbitrary.
12232 IF(PYR(0).GT.0.5D0) JS=2
12233 MINT(20+JS)=KFPR(ISUB,1)
12234 MINT(23-JS)=KFPR(ISUB,2)
12237 ELSEIF(ISUB.EQ.394) THEN
12238 C...q + g -> q + G*; th = (p(f) - p(f))**2
12239 IF(MINT(15).EQ.21) JS=2
12240 MINT(23-JS)=KFPR(ISUB,2)
12242 KCS=ISIGN(1,MINT(14+JS))
12244 ELSEIF(ISUB.EQ.395) THEN
12245 C...g + g -> G* + g; th arbitrary.
12246 IF(PYR(0).GT.0.5D0) JS=2
12247 MINT(23-JS)=KFPR(ISUB,2)
12251 ELSEIF(ISUB.LE.420) THEN
12252 IF(ISUB.EQ.401) THEN
12253 C...g + g -> t + b + H+/-
12254 KCS=(-1)**INT(1.5D0+PYR(0))
12255 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12256 MINT(22)=ISIGN(5,-KCS)
12257 KCC=11+INT(0.5D0+PYR(0))
12258 KFRES=ISIGN(KFHIGG,-KCS)
12260 ELSEIF(ISUB.EQ.402) THEN
12261 C...q + qbar -> t + b + H+/-
12262 KFL=(-1)**INT(1.5D0+PYR(0))
12263 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12264 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12266 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12270 C...Additional code by Stefan Wolf
12271 ELSEIF(ISUB.LE.430) THEN
12272 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12273 C...g + g -> QQ~[n] + g
12274 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12275 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12276 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12277 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12278 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12279 C...[g + g -> g + g; th arbitrary]
12280 MINT(21)=KFPR(ISUBSV,1)
12281 MINT(22)=KFPR(ISUBSV,2)
12282 IF(ISUB.EQ.421) THEN
12284 KCS=(-1)**INT(1.5D0+PYR(0))
12287 KCS=(-1)**INT(1.5D0+PYR(0))
12290 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12291 C...q + g -> q + QQ~[n]
12292 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12293 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12294 C...KCC copied from ISUB.EQ.28
12295 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12296 IF(MINT(15).EQ.21) JS=2
12297 MINT(23-JS)=KFPR(ISUBSV,2)
12299 IF(MINT(15).EQ.21) KCC=KCC+2
12300 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12301 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12303 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12304 C...q + q~ -> g + QQ~[n]
12305 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12306 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12307 C...KCC copied from ISUB.EQ.13
12308 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12309 IF(PYR(0).GT.0.5) JS=2
12311 MINT(23-JS)=KFPR(ISUBSV,2)
12315 ELSEIF(ISUB.LE.440) THEN
12316 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12317 C...g + g -> QQ~[n] + g
12318 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12319 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12320 C...KCC and KCS copied from ISUB.EQ.86-89
12321 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12322 MINT(21)=KFPR(ISUBSV,1)
12323 MINT(22)=KFPR(ISUBSV,2)
12325 KCS=(-1)**INT(1.5D0+PYR(0))
12327 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12328 C...q + g -> q + QQ~[n]
12329 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12330 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12331 C...KCC and KCS copied from ISUB.EQ.112
12332 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12333 IF(MINT(15).EQ.21) JS=2
12334 MINT(23-JS)=KFPR(ISUBSV,2)
12336 KCS=ISIGN(1,MINT(14+JS))
12338 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12339 C...q + q~ -> g + QQ~[n]
12340 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12341 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12342 C...KCC copied from ISUB.EQ.111
12343 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12344 IF(PYR(0).GT.0.5) JS=2
12346 MINT(23-JS)=KFPR(ISUBSV,2)
12353 IF(ISET(ISUB).EQ.11) THEN
12354 C...Store documentation for user-defined processes
12355 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12356 KUPPO(1)=MINT(83)+5
12357 KUPPO(2)=MINT(83)+6
12361 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12370 IF(IDUP(IUP).EQ.0) K(I,2)=90
12372 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12380 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12383 C...Store final state partons for user-defined processes
12388 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12390 IF(IDUP(IUP).EQ.0) K(N,2)=90
12391 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12394 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12398 C...Search for daughters of intermediate colourless particles.
12399 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12400 DO 475 IUPDAU=IUP+1,NUP
12401 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12403 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12411 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12413 C...Arrange colour flow for user-defined processes
12417 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12418 IF(K(I1,1).EQ.1) K(I1,1)=3
12419 IF(K(I1,1).EQ.11) K(I1,1)=14
12420 C...Find a not yet considered colour/anticolour line.
12422 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12425 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12429 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12430 C...Find all others belonging to same line.
12433 DO 520 IUP2=IUP1+1,NUP
12436 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12437 IF(ISDE2.EQ.ISDE1) THEN
12438 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12439 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12441 ELSEIF(I4.NE.0) THEN
12442 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12443 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12445 ELSEIF(IUP2.LE.2) THEN
12446 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12447 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12450 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12451 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12461 ELSEIF(IDOC.EQ.7) THEN
12462 C...Resonance not decaying; store kinematics
12477 C...Special cases: colour flow in coloured resonances
12478 KCRES=PYCOMP(KFRES)
12479 IF(KCHG(KCRES,2).NE.0) THEN
12483 IF(KCS.EQ.-1) JC=3-J
12484 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12485 & MINT(84)+ICOL(KCC,1,JC)
12486 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12487 & MINT(84)+ICOL(KCC,2,JC)
12488 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12489 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12498 ELSEIF(IDOC.EQ.8) THEN
12499 C...2 -> 2 processes: store outgoing partons in their CM-frame
12502 KCA=PYCOMP(MINT(20+JT))
12504 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12506 K(I,3)=MINT(83)+IDOC+JT-2
12508 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12509 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12511 P(I,5)=PYMASS(K(I,2))
12513 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12514 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12516 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12517 KFA1=IABS(MINT(21))
12518 KFA2=IABS(MINT(22))
12519 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12527 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12528 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12529 P(IPU4,4)=SHR-P(IPU3,4)
12530 P(IPU4,3)=-P(IPU3,3)
12535 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12536 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12538 ELSEIF(IDOC.EQ.9) THEN
12539 C...2 -> 3 processes: store outgoing partons in their CM frame
12542 KCA=PYCOMP(MINT(20+JT))
12544 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12546 K(I,3)=MINT(83)+IDOC+JT-3
12548 C...t and b in opposide order in event list as compared to
12549 C...matrix element?
12550 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12551 IF(IABS(K(I,2)).LE.22) THEN
12552 P(I,5)=PYMASS(K(I,2))
12554 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12556 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12557 P(I,1)=PT*COS(VINT(198+5*JTA))
12558 P(I,2)=PT*SIN(VINT(198+5*JTA))
12562 K(IPU5,3)=MINT(83)+IDOC
12564 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12565 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12566 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12567 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12568 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12570 P(IPU5,3)=PMT3*SINH(VINT(211))
12571 P(IPU5,4)=PMT3*COSH(VINT(211))
12572 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12573 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12574 IF(SQL12.LE.0D0) THEN
12578 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12579 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12580 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12581 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12582 C...t and b in opposide order in event list as compared to
12584 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12585 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12586 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12588 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12589 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12595 ELSEIF(IDOC.EQ.11) THEN
12596 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12597 PHI(1)=PARU(2)*PYR(0)
12602 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12604 K(I,3)=MINT(83)+IDOC+JT-2
12605 P(I,5)=PYMASS(K(I,2))
12606 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12610 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12611 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12612 P(I,1)=PTABS*COS(PHI(JT))
12613 P(I,2)=PTABS*SIN(PHI(JT))
12614 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12615 P(I,4)=0.5D0*SHPR*Z(JT)
12619 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12623 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12624 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12625 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12632 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12633 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12634 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12635 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12644 ELSEIF(IDOC.EQ.12) THEN
12645 C...Z0 and W+/- scattering: store bosons and outgoing partons
12646 PHI(1)=PARU(2)*PYR(0)
12648 JTRAN=INT(1.5D0+PYR(0))
12652 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12654 K(I,3)=MINT(83)+IDOC+JT-2
12655 P(I,5)=PYMASS(K(I,2))
12656 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12657 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12658 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12659 P(I,1)=PTABS*COS(PHI(JT))
12660 P(I,2)=PTABS*SIN(PHI(JT))
12661 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12662 P(I,4)=0.5D0*SHPR*Z(JT)
12665 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12668 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12673 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12674 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12675 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12678 K(IPU,2)=KFPR(ISUB,JT)
12679 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12680 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12681 K(IPU,3)=MINT(83)+8+JT
12682 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12683 P(IPU,5)=PYMASS(K(IPU,2))
12685 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12687 MINT(22+JT)=K(IPU,2)
12689 C...Find rotation and boost for hard scattering subsystem
12692 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12693 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12694 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12695 GAMCM=(P(I1,4)+P(I2,4))/SHR
12696 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12697 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12698 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12699 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12700 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12701 PHICM=PYANGL(PX,PY)
12702 C...Store hard scattering subsystem. Rotate and boost it
12703 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12705 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12707 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12708 PHIWZ=VINT(24)-PHICM
12709 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12710 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12711 P(IPU5,3)=PABS*CTHWZ
12712 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12713 P(IPU6,1)=-P(IPU5,1)
12714 P(IPU6,2)=-P(IPU5,2)
12715 P(IPU6,3)=-P(IPU5,3)
12716 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12717 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12729 MINT(8)=MINT(83)+10
12732 IF(ISET(ISUB).EQ.11) THEN
12733 ELSEIF(IDOC.GE.8) THEN
12734 C...Store colour connection indices
12737 IF(KCS.EQ.-1) JC=3-J
12738 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12739 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12740 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12741 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12742 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12743 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12744 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12745 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12748 C...Copy outgoing partons to documentation lines
12750 IF(IDOC.EQ.9) IMAX=3
12752 I1=MINT(83)+IDOC-IMAX+I
12756 IF(IDOC.LE.9) K(I1,3)=0
12757 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12763 ELSEIF(IDOC.EQ.9) THEN
12764 C...Store colour connection indices
12767 IF(KCS.EQ.-1) JC=3-J
12768 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12769 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12770 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12771 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12772 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12773 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12774 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12775 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12776 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12777 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12780 C...Copy outgoing partons to documentation lines
12782 I1=MINT(83)+IDOC-3+I
12793 C...Copy outgoing partons to list of allowed radiators.
12795 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12796 DO 690 I=MINT(84)+3,N
12799 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12803 C...Low-pT events: remove gluons used for string drawing purposes
12804 IF(ISUB.EQ.95) THEN
12805 IF(MINT(35).LE.1) THEN
12806 K(IPU3,1)=K(IPU3,1)+10
12807 K(IPU4,1)=K(IPU4,1)+10
12813 DO 720 I=MINT(83)+5,MINT(83)+8
12823 C***********************************************************************
12826 C...Handles intertwined pT-ordered spacelike initial-state parton
12827 C...and multiple interactions.
12829 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12830 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12831 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12832 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12834 C...Double precision and integer declarations.
12835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12836 IMPLICIT INTEGER(I-N)
12837 INTEGER PYK,PYCHGE,PYCOMP
12840 DOUBLE PRECISION PYALPS
12841 C...Parameter statement for maximum size of showers.
12842 PARAMETER (MAXNUR=1000)
12844 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12845 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12846 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12847 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12848 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12849 COMMON/PYINT1/MINT(400),VINT(400)
12850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12851 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12852 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12853 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12854 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12855 COMMON/PYCTAG/NCT,MCT(4000,2)
12856 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12857 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12858 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12859 C...Local arrays and saved variables.
12860 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12861 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12864 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12865 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12867 C----------------------------------------------------------------------
12868 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12869 C...done only once per event, while MODE=0 is repeated each time the
12870 C...evolution needs to be restarted.
12871 IF (MODE.EQ.-1) THEN
12875 C...Store hard scattering variables
12892 C...Set shat for hardest scattering
12894 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12897 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12901 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12902 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12903 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12905 C----------------------------------------------------------------------
12906 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12907 C...interaction initiators, with no previous evolution. Check the input
12908 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12909 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12910 C...smaller than the CM energy / 2.)
12911 ELSEIF (MODE.EQ.0) THEN
12912 C...Reset counters and switches
12918 C...Reset hard scattering variables
12929 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12930 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12933 C...Reset statistics on activity in event.
12938 C...Reset extra companion reweighting factor
12941 C...We do not generate MI for soft process (ISUB=95), but the
12942 C...initialization must be done regardless, for later purposes.
12945 C...Initialize multiple interactions.
12946 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12947 IF(MINT(51).NE.0) RETURN
12949 C...Decide whether quarks in hard scattering were valence or sea
12953 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12954 IF(MINT(51).NE.0) RETURN
12957 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12959 IF(MSTP(70).EQ.0) THEN
12961 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12962 ELSEIF(MSTP(70).EQ.1) THEN
12963 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12964 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12966 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12967 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12969 C...Also store PT2MIN in VINT(17).
12970 180 VINT(17)=PT2MIN
12972 C...Set FS masses zero now.
12976 C...Initialize IS showers with VINT(56) as max scale.
12978 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12979 IF(MINT(51).NE.0) RETURN
12983 C----------------------------------------------------------------------
12984 C...MODE= 1: Evolve event from PTMAX to PTMIN.
12985 ELSEIF (MODE.EQ.1) THEN
12987 C...Skip if no phase space.
12988 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12990 C...Starting pT2 max scale (to be udpated successively).
12993 C...Evolve two sides of the event to find which branches at highest pT.
12998 C...Loop over current shower initiators.
12999 IF (MSTP(61).GE.1) THEN
13000 DO 230 MI=1,MINT(31)
13001 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13003 IF (MI.EQ.1) ISUB=ISUBHD
13006 C...Set up shat, initiator x values, and x remaining in BR.
13008 VINT(141)=XMI(1,MI)
13009 VINT(142)=XMI(2,MI)
13012 DO 210 JI=1,MINT(31)
13013 IF (JI.EQ.MINT(36)) GOTO 210
13014 VINT(143)=VINT(143)-XMI(1,JI)
13015 VINT(144)=VINT(144)-XMI(2,JI)
13017 C...Loop over sides.
13018 C...Generate trial branchings for this interaction. The hardest
13019 C...branching so far is automatically updated if necessary in /PYISMX/.
13022 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13023 IF (MINT(51).NE.0) RETURN
13028 C...Generate trial additional interaction.
13029 MINT(36)=MINT(31)+1
13030 240 IF (MOD(MSTP(81),10).GE.1) THEN
13032 C...Set up X remaining in BR.
13035 DO 250 JI=1,MINT(31)
13036 VINT(143)=VINT(143)-XMI(1,JI)
13037 VINT(144)=VINT(144)-XMI(2,JI)
13039 C...Generate trial interaction
13040 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13041 IF (MINT(51).EQ.1) RETURN
13044 C...And the winner is:
13045 IF (PT2MX.LT.PT2MIN) THEN
13047 ELSEIF (JSMX.EQ.0) THEN
13048 C...Accept additional interaction (may still fail).
13049 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13050 IF(MINT(51).NE.0) RETURN
13051 IF (IFAIL.EQ.0) THEN
13052 SHAT(MINT(36))=VINT(44)
13053 C...Decide on flavours (valence/sea/companion).
13056 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13057 IF(MINT(51).NE.0) RETURN
13060 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13061 C...Reconstruct kinematics of acceptable ISR branching.
13062 C...Set up shat, initiator x values, and x remaining in BR.
13065 VINT(44)=SHAT(MINT(36))
13066 VINT(141)=XMI(1,MINT(36))
13067 VINT(142)=XMI(2,MINT(36))
13070 DO 280 JI=1,MINT(31)
13071 IF (JI.EQ.MINT(36)) GOTO 280
13072 VINT(143)=VINT(143)-XMI(1,JI)
13073 VINT(144)=VINT(144)-XMI(2,JI)
13076 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13077 IF (MINT(51).EQ.1) RETURN
13078 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13079 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13080 MINT(354)=MINT(354)+1
13081 VINT(354)=VINT(354)+SQRT(PT2MX)
13082 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13083 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13084 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13087 C...Update PT2 iteration scale.
13090 C...Loop back to continue evolution.
13091 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13092 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13094 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13097 C----------------------------------------------------------------------
13098 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13099 ELSEIF (MODE.EQ.2) THEN
13101 C...Revert to "ordinary" meanings of some parameters.
13103 MINT(12+JS)=K(IMI(JS,1,1),2)
13104 VINT(140+JS)=XMI(JS,1)
13105 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13107 DO 300 MI=1,MINT(31)
13108 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13112 C...Restore saved quantities for hardest interaction.
13127 C*********************************************************************
13130 C...Generates spacelike parton showers.
13132 SUBROUTINE PYSSPA(IPU1,IPU2)
13134 C...Double precision and integer declarations.
13135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13136 IMPLICIT INTEGER(I-N)
13137 INTEGER PYK,PYCHGE,PYCOMP
13139 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13142 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13144 COMMON/PYINT1/MINT(400),VINT(400)
13145 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13146 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13147 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13149 C...Local arrays and data.
13150 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13151 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13152 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13153 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13154 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13157 C...Read out basic information; set global Q^2 scale.
13162 VINT2R=VINT(2)*VINT(143)*VINT(144)
13163 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13164 &MIN(VINT2R,PARP(67)*VINT(56))
13167 C...Define which processes ME corrections have been implemented for.
13169 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13170 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13171 & ISUB.EQ.144) MECOR=1
13172 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13173 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13176 C...Initialize QCD evolution and check phase space.
13180 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13183 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13184 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13185 Q2INT=SQRT(Q0S*Q2EFF)
13186 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13187 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13188 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13190 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13193 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13194 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13195 Q2INT=SQRT(Q0S*Q2EFF)
13196 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13197 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13198 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13205 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13207 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13208 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13209 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13210 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13214 C...Initialize QED evolution and check phase space.
13218 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13219 &SPME=PMAS(13,1)**2
13220 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13221 &SPME=PMAS(15,1)**2
13222 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13225 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13227 TEMX=LOG(Q2MX/SPME)
13228 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13230 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13235 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13237 C...Loopback point in case of failure to reconstruct kinematics.
13245 IF(LOOP.GT.100) THEN
13255 C...Initial values: flavours, momenta, virtualities.
13258 KFBEAM(JT)=MINT(10+JT)
13259 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13260 KFLS(JT)=MINT(14+JT)
13261 KFLS(JT+2)=KFLS(JT)
13263 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13264 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13266 Q2S(JT)=FCQ2MX*Q2MX
13273 C...Calculate initial parton distribution weights.
13274 MINT(105)=MINT(102+JT)
13275 MINT(109)=MINT(106+JT)
13276 VINT(120)=VINT(2+JT)
13278 C.... Store side in MINT(124)
13281 IF(XS(JT).LT.1D0-XEE) THEN
13282 IF(MINT(31).GE.2) MINT(30)=JT
13283 IF(MSTP(57).LE.1) THEN
13284 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13286 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13290 XFS(JT,KFL)=XFB(KFL)
13292 C...Special kinematics check for c/b quarks (that g -> c cbar or
13293 C...b bbar kinematically possible).
13294 KFLCB=IABS(KFLS(JT))
13295 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13296 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13303 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13305 C...Find if interference with final state partons.
13307 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13311 KCA=PYCOMP(IABS(KFLS(I)))
13312 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13314 IF(KCFI(I).NE.0) THEN
13315 IF(I.EQ.1) IPFS=IPUS1
13316 IF(I.EQ.2) IPFS=IPUS2
13318 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13319 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13320 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13322 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13324 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13329 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13332 C...Pick up leg with highest virtuality.
13336 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13337 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13338 IF(MORE(JT).EQ.0) JT=3-JT
13343 XFB(KFL)=XFS(JT,KFL)
13348 C...Check if allowed to branch.
13350 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13352 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13353 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13356 IF(MINT(44+JT).EQ.3) THEN
13358 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13359 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13361 C***Currently kill QED shower for resolved photoproduction.
13362 IF(MINT(18+JT).EQ.1) MEEV=0
13363 C***Currently kill shower for W inside electron.
13364 IF(IABS(KFLB).EQ.24) THEN
13369 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13371 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13376 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13380 IF(MSTP(62).LE.1) THEN
13381 IF(ZS(JT).GT.0.99999D0) THEN
13384 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13385 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13386 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13388 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13389 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13392 ALSDUM=PYALPS(FQ2C*Q2B)
13393 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13395 B0=(33D0-2D0*MSTU(118))/6D0
13397 IF(MEEV.EQ.2) TEVEB=TEVCB
13401 C...Select side for interference with final state partons.
13402 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13405 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13407 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13408 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13409 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13411 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13415 C...Calculate preweighting factor for ME-corrected processes.
13416 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13418 C...Calculate Altarelli-Parisi weights.
13424 C...q -> q (g or gamma emission), g -> q.
13425 IF(IABS(KFLB).LE.10) THEN
13426 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13427 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13429 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13430 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13432 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13433 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13434 WTAPC(21)=WTGF*WTAPC(21)
13435 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13437 C...f -> f, gamma -> f.
13438 ELSEIF(IABS(KFLB).LE.20) THEN
13439 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13440 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13441 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13442 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13443 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13444 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13445 WTAPE(22)=WTGF*WTAPE(22)
13447 C...f -> g, g -> g.
13448 ELSEIF(KFLB.EQ.21) THEN
13449 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13450 DO 180 KFL=1,MSTP(58)
13454 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13455 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13456 DO 190 KFL=1,MSTP(58)
13457 WTAPC(KFL)=WTFG*WTAPC(KFL)
13458 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13460 WTAPC(21)=WTGG*WTAPC(21)
13462 C...f -> gamma, W+, W-.
13463 ELSEIF(KFLB.EQ.22) THEN
13464 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13467 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13468 WTAPE(11)=WTFG*WTAPE(11)
13469 WTAPE(-11)=WTFG*WTAPE(-11)
13471 ELSEIF(KFLB.EQ.24) THEN
13472 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13473 & (XEE*(XB+XEE)))/XB
13474 ELSEIF(KFLB.EQ.-24) THEN
13475 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13476 & (XEE*(XB+XEE)))/XB
13479 C...Calculate parton distribution weights and sum.
13482 IF(NTRY.GT.500) THEN
13488 XFBO=MAX(1D-10,XFB(KFLB))
13490 WTSF(KFL)=XFB(KFL)/XFBO
13491 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13492 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13494 WTSUMC=MAX(0.0001D0,WTSUMC)
13495 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13497 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13500 IF(NTRY2.GT.500) THEN
13505 IF(MSTP(64).LE.0) THEN
13506 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13507 ELSEIF(MSTP(64).EQ.1) THEN
13508 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13510 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13514 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13515 & (PARU(101)*FWTE*WTSUME*TEMX)))
13516 ELSEIF(MEEV.EQ.2) THEN
13517 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13520 C...Translate t into Q2 scale; choose between QCD and QED evolution.
13521 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13522 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13523 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13524 C...Ensure that Q2 is above threshold for charm/bottom.
13526 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13528 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13529 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13530 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13531 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13534 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13536 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13539 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13540 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13541 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13542 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13543 IF(Q2EB.GT.Q2MNE) MCE=2
13544 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13545 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13546 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13547 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13548 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13549 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13551 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13552 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13555 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13556 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13559 C...Evolution possibly ended. Update t values.
13563 ELSEIF(MCE.EQ.1) THEN
13566 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13567 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13571 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13574 C...Select flavour for branching parton.
13575 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13576 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13579 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13580 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13581 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13582 IF(KFLA.EQ.25) THEN
13587 C...Choose z value and corrective weight.
13589 C...q -> q + g or q -> q + gamma.
13590 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13591 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13592 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13593 WTZ=0.5D0*(1D0+Z**2)
13595 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13596 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13597 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13598 C...f -> f + gamma.
13599 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13600 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13601 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13602 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13604 Z=XB+XB*(XEE/(1D0-XEE))*
13605 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13607 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13608 C...f -> gamma + f.
13609 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13610 Z=XB+XB*(XEE/(1D0-XEE))*
13611 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13612 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13614 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13615 Z=XB+XB*(XEE/(1D0-XEE))*
13616 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13617 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13618 & (Q2B/(Q2B+PMAS(24,1)**2))
13620 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13621 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13622 WTZ=1D0-2D0*Z*(1D0-Z)
13624 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13625 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13626 WTZ=(1D0-Z*(1D0-Z))**2
13627 C...gamma -> f + fbar.
13628 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13629 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13630 WTZ=1D0-2D0*Z*(1D0-Z)
13632 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13634 C...Option with resummation of soft gluon emission as effective z shift.
13636 IF(MSTP(65).GE.1) THEN
13638 IF(KFLB.NE.21) RSOFT=8D0/3D0
13639 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13640 IF(Z.LE.XB) GOTO 220
13643 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13644 IF(MSTP(64).GE.2) THEN
13645 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13646 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13647 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13648 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13652 C...Remove kinematically impossible branchings.
13653 UHAT=Q2B-DSH*(1D0-Z)/Z
13654 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13656 C...Select phi angle of branching at random.
13657 PHIBR=PARU(2)*PYR(0)
13659 C...Matrix-element corrections for some processes.
13660 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13661 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13662 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13664 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13665 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13667 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13668 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13670 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13671 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13676 C...Impose angular constraint in first branching from interference
13677 C...with final state partons.
13679 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13680 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13681 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13682 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13683 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13684 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13688 C...Option with angular ordering requirement.
13689 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13690 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13691 IF(THE2T.GT.THE2(JT)) GOTO 220
13695 C...Weighting with new parton distributions.
13696 MINT(105)=MINT(102+JT)
13697 MINT(109)=MINT(106+JT)
13698 VINT(120)=VINT(2+JT)
13700 C.... Store side in MINT(124)
13703 IF(MINT(31).GE.2) MINT(30)=JT
13704 IF(MSTP(57).LE.1) THEN
13705 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13707 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13710 IF(XFBN.LT.1D-20) THEN
13711 IF(KFLA.EQ.KFLB) THEN
13717 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13718 TEVCB=0.5D0*(TEVCBS+TEVCB)
13720 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13721 TEVEB=0.5D0*(TEVEBS+TEVEB)
13733 C.... Store side in MINT(124)
13736 IF(MINT(31).GE.2) MINT(30)=JT
13737 IF(MSTP(57).LE.1) THEN
13738 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13740 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13743 IF(XFAN.LT.1D-20) GOTO 200
13745 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13747 C...Define two hard scatterers in their CM-frame.
13748 260 IF(N.EQ.NS+2) THEN
13750 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13753 IF(JR.EQ.1) IPO=IPUS1
13754 IF(JR.EQ.2) IPO=IPUS2
13764 P(I,3)=DPLCM*(-1)**(JR+1)
13765 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13766 P(I,5)=-SQRT(DQ2(JR))
13769 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13770 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13773 C...Find maximum allowed mass of timelike parton.
13774 ELSEIF(N.GT.NS+2) THEN
13779 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13780 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13781 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13782 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13783 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13785 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13786 & 1D-10*DPD(1)) IKIN=1
13787 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13788 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13789 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13790 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13792 C...Generate timelike parton shower (if required).
13799 C...f -> f + g (gamma).
13800 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13802 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13803 C...f -> g (gamma, W+-) + f.
13804 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13806 IF(KFLS(JT+2).EQ.24) THEN
13808 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13811 C...g (gamma) -> f + fbar, g + g.
13813 K(IT,2)=-KFLS(JT+2)
13814 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13817 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13818 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13819 P(IT,5)=PYMASS(K(IT,2))
13820 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13821 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13824 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13825 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13826 IF(MSTP(63).EQ.1) THEN
13828 ELSEIF(MSTP(63).EQ.2) THEN
13829 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13833 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13834 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13835 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13836 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13837 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13839 CALL PYSHOW(IT,0,SQRT(Q2TIM))
13842 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13845 C...Reconstruct kinematics of branching: timelike parton shower.
13847 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13848 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13849 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13850 & (4D0*DSH*DPC(3)**2)
13851 IF(DPT2.LT.0D0) GOTO 100
13852 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13853 & DSHR)/DPC(3)-DPC(3)
13855 P(IT,3)=DPB(1)*(-1)**(JT+1)
13856 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13858 DPB(1)=SQRT(DPB(1)**2+DPT2)
13859 DPB(2)=SQRT(DPB(1)**2+DMS)
13861 DPB(4)=SQRT(DPB(3)**2+DMS)
13862 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13864 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13865 THE=PYANGL(P(IT,3),P(IT,1))
13866 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13869 C...Reconstruct kinematics of branching: spacelike parton.
13878 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13879 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13880 P(N+1,5)=-SQRT(DQ2(3))
13882 C...Define colour flow of branching.
13887 C...f -> f + gamma (Z, W).
13888 IF(IABS(K(IT,2)).GE.22) THEN
13892 C...f -> gamma (Z, W) + f.
13893 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13896 C...gamma -> q + qbar, g + g.
13897 ELSEIF(K(N+1,2).EQ.22) THEN
13903 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13907 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13910 C...qbar -> qbar + g.
13911 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13914 C...qbar -> g + qbar.
13915 ELSEIF(K(N+1,2).LT.0) THEN
13918 C...g -> g + g; g -> q + qbar.
13919 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13926 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13927 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13928 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13929 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13930 IF(ID1.NE.ID2) THEN
13931 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13932 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13935 IF(K(IT,1).EQ.1) THEN
13940 C...Boost to new CM-frame.
13941 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13942 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13943 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13944 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13945 IR=N+(JT-1)*(IS(1)-N)
13946 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13949 C...Global statistics.
13950 MINT(352)=MINT(352)+1
13951 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13952 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13955 C...Update kinematics variables.
13958 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
13961 C...Save quantities; loop back.
13965 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13966 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13967 KFLS(JT+2)=KFLS(JT)
13972 XFS(JT,KFL)=XFA(KFL)
13981 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13982 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13983 IF(MSTU(21).GE.1) N=NS
13984 IF(MSTU(21).GE.1) RETURN
13986 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13988 C...Boost hard scattering partons to frame of shower initiators.
13990 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13996 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
13997 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
13998 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14000 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14001 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14002 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14004 C...Store user information. Reset Lambda value.
14005 IF(MINT(31).LE.1) THEN
14006 K(IPU1,3)=MINT(83)+3
14007 K(IPU2,3)=MINT(83)+4
14009 K(IPU1,3)=MINT(83)+1
14010 K(IPU2,3)=MINT(83)+2
14013 MINT(12+JT)=KFLS(JT)
14014 VINT(140+JT)=XS(JT)
14015 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14016 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14022 C*********************************************************************
14025 C...Generates pT-ordered spacelike initial-state parton showers and
14026 C...trial joinings.
14027 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14028 C... interaction initiators at PT2NOW.
14029 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14030 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14031 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14032 C... is below PT2CUT.
14033 C... (Also generate test joinings if MSTP(96)=1.)
14034 C...MODE= 1: Accept stored shower branching. Update event record etc.
14035 C...PT2NOW : Starting (max) PT2 scale for evolution.
14036 C...PT2CUT : Lower limit for evolution.
14037 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14038 C...IFAIL : Status return code. IFAIL=0 when all is well.
14040 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14042 C...Double precision and integer declarations.
14043 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14044 IMPLICIT INTEGER(I-N)
14045 INTEGER PYK,PYCHGE,PYCOMP
14046 C...Parameter statement for maximum size of showers.
14047 PARAMETER (MAXNUR=1000)
14049 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14050 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14051 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14052 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14053 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14054 COMMON/PYINT1/MINT(400),VINT(400)
14055 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14056 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14057 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14058 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14059 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14060 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14061 COMMON/PYCTAG/NCT,MCT(4000,2)
14062 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14063 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14064 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14065 C...Local variables
14066 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14067 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14068 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14069 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14070 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14071 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14072 C...For check on excessive weights.
14075 C...Only give errors for very large weights, otherwise just warnings
14076 DATA WTEMAX /1.5D0/
14077 C...Only give errors for large pT, otherwise just warnings
14082 C----------------------------------------------------------------------
14083 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14084 C...starting from the hardest interaction initiators.
14085 IF (MODE.EQ.-1) THEN
14086 C...Set hard scattering SHAT.
14088 C...Mass thresholds and Lambda for QCD evolution.
14089 AEM2PI=PARU(101)/PARU(2)
14093 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14094 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14095 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14096 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14099 C...Massive quark forced creation threshold (in M**2).
14101 C...Set upper limit for X (ensures some X left for beam remnant).
14102 XMXC=1D0-2D0*PARP(111)/VINT(1)
14104 IF (MSTP(61).GE.1) THEN
14105 C...Initial values: flavours, momenta, virtualities.
14109 C...Special kinematics check for c/b quarks (that g -> c cbar or
14110 C...b bbar kinematically possible).
14111 KFLB=K(IMI(JS,1,1),2)
14113 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14114 C...Check PT2MAX > mQ^2
14115 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14116 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14117 & 'No Q creation possible.')
14121 C...Check for physical z values (m == MQ / sqrt(s))
14122 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14123 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14124 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14125 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14126 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14137 C...Zero joining array
14143 C----------------------------------------------------------------------
14144 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14145 C...MINT(30). Store if emission PT2 scale is largest so far.
14146 C...Also generate test joinings if MSTP(96)=1.
14147 ELSEIF(MODE.EQ.0) THEN
14152 C...No shower for structureless beam
14153 IF (MINT(44+JS).EQ.1) RETURN
14156 C...Absolute shower max scale = VINT(56)
14157 PT2=MIN(PT2NOW,VINT(56))
14158 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14159 C...Define for which processes ME corrections have been implemented.
14160 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14161 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14162 & .142.OR.ISUB.EQ.144) MECOR=1
14163 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14164 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14165 C...Calculate preweighting factor for ME-corrected processes.
14166 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14168 C...Basic info on daughter for which to find mother.
14169 KFLB=K(IMI(JS,MI,1),2)
14171 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14172 C...second companion.
14173 KSVCB=MAX(-1,IMI(JS,MI,2))
14174 C...Treat "first" companion of a pair like an ordinary sea quark
14175 C...(except that creation diagram is not allowed)
14176 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14177 C...X (rescaled to [0,1])
14178 XB=XMI(JS,MI)/VINT(142+JS)
14179 C...Massive quarks (use physical masses.)
14182 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14184 IF (KFLBA.EQ.5) RMQ2=RMB2
14185 C...Special threshold treatment for non-photon beams
14186 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14189 C...Flags for parton distribution calls.
14190 MINT(105)=MINT(102+JS)
14191 MINT(109)=MINT(106+JS)
14192 VINT(120)=VINT(2+JS)
14194 C...Calculate initial parton distribution weights.
14195 IF(XB.GE.XMXC) THEN
14197 ELSEIF(MQMASS.EQ.0) THEN
14198 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14200 C...Initialize massive quark PT2 dependent pdf underestimate.
14202 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14203 C.!.Tentative treatment of massive valence quarks.
14204 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14206 TPM0=LOG(PT20/RMQ2)
14209 IF (KFLBA.LE.6) THEN
14210 C...For quarks, only include respective sea, val, or cmp part.
14211 IF (KSVCB.LE.0) THEN
14212 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14214 C...Find companion's companion
14217 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14221 C...Momentum fraction of the companion quark.
14222 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14224 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14228 C...Determine overestimated z range: switch at c and b masses.
14229 130 IF (PT2.GT.TMIN*RMB2) THEN
14231 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14234 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14236 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14245 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14246 ALAM2=ALAM2/PARP(64)
14247 C...Overestimated ZMAX:
14248 IF (MQMASS.EQ.0) THEN
14250 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14253 C...Massive (limit for bremsstrahlung diagram > creation)
14254 FMQ=SQRT(RMQ2/SHTNOW(MI))
14259 C...If kinematically impossible then do not evolve.
14260 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14262 C...Reset Altarelli-Parisi and PDF weights.
14269 C...Zero joining weights and compute X(partner) and X(mother) values.
14270 IF (MSTP(96).NE.0) THEN
14272 DO 150 MJ=1,MINT(31)
14275 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14276 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14281 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14282 C...q -> q, g -> q or q -> q + gamma (already set which).
14283 IF(KFLBA.LE.5) THEN
14284 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14285 IF (KSVCB.LT.0) THEN
14286 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14288 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14289 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14290 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14292 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14293 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14294 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14295 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14296 WTAP(KFLB)=WTFF*WTAP(KFLB)
14297 WTAP(21)=WTGF*WTAP(21)
14300 IF (KSVCB.GE.1) THEN
14301 C...Kill normal creation but add joining diagrams for cmp quark.
14303 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14304 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14305 & " quark here. Not handled yet, giving up!")
14310 C...Check for possible joinings
14311 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14312 C...Find companion's companion.
14315 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14316 IF (MJOIND(JS,MJ).EQ.0) THEN
14319 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14320 IF (WTAPJ(MJ).GT.1D-6) THEN
14326 C...Add trial gluon joinings.
14327 DO 170 MJ=1,MINT(31)
14328 KFLC=K(IMI(JS,MJ,1),2)
14329 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14330 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14331 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14332 IF (WTAPJ(MJ).GT.1D-6) THEN
14339 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14340 C...Kill creation diagram for val quarks and sea quarks with companions.
14342 ELSEIF (MQMASS.EQ.0) THEN
14343 C...Extra safety factor for massless sea quark creation.
14344 WTAP(21)=WTAP(21)*1.25D0
14347 C... q -> g, g -> g.
14348 ELSEIF(KFLB.EQ.21) THEN
14349 C...Here we decide later whether a quark picked up is valence or
14350 C...sea, so we maintain the extra factor sqrt(z) since we deal
14351 C...with the *sum* of sea and valence in this context.
14352 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14353 C...new: do not allow backwards evol to pick up heavy flavour.
14354 DO 180 KFL=1,MIN(3,MSTP(58))
14358 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14359 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14361 WTAP(21)=WTGG*WTAP(21)
14363 C...Check for possible joinings (companions handled separately above)
14364 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14366 DO 190 MJ=1,MINT(31)
14367 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14369 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14370 IF (KSVCC.GE.1) GOTO 190
14371 KFLC=K(IMI(JS,MJ,1),2)
14372 C...Only try g -> g + g once.
14373 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14374 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14375 IF (KFLC.EQ.21) THEN
14376 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14378 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14380 IF (WTAPJ(MJ).GT.1D-6) THEN
14389 C...Initialize massive quark evolution
14390 IF (MQMASS.NE.0) THEN
14391 RML=(RMQ2+VINT(18))/ALAM2
14393 TPL=LOG((PT2+VINT(18))/ALAM2)
14394 TPM=LOG((PT2+VINT(18))/RMQ2)
14395 WN=WTAP(21)*WPDF0/B0
14399 C...Loopback point for iteration
14403 IF(NTRY.GT.500) THEN
14404 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14409 C... Calculate PDF weights and sum for evolution rate.
14411 XFBO=MAX(1D-10,XFB(KFLB))
14413 WTPDF(KFL)=XFB(KFL)/XFBO
14414 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14416 C...Only add gluon mother diagram for massless KFLB.
14417 IF(MQMASS.EQ.0) THEN
14418 WTPDF(21)=XFB(21)/XFBO
14419 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14421 WTSUM=MAX(0.0001D0,WTSUM)
14423 C...Add joining diagrams where applicable.
14425 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14426 DO 220 MJ=1,MINT(31)
14427 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14428 WTPDFJ(MJ)=1D0/XFBO
14429 C...x and x*pdf (+ sea/val) for parton C.
14430 KFLC=K(IMI(JS,MJ,1),2)
14432 KSVCC=MAX(-1,IMI(JS,MJ,2))
14433 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14436 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14438 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14439 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14440 ELSEIF (KSVCC.GE.1) THEN
14441 print*, 'error! parton C is companion!'
14443 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14444 C...x and x*pdf (+ sea/val) for parton A.
14447 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14450 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14455 IF (KSVCA.LE.0) THEN
14456 C...Consider C the "evolved" parton if B is gluon. Val/sea
14457 C...counting will then be done correctly in PYPDFU.
14458 IF (KFLBA.EQ.21) MINT(36)=MJ
14459 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14461 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14463 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14464 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14466 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14467 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14471 C...Pick normal pT2 (in overestimated z range).
14474 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14477 C...Evolve q -> q gamma separately, pick it if larger pT.
14478 IF(KFLBA.LE.5) THEN
14479 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14480 IF(PT2QED.GT.PT2) THEN
14487 C... Evolve massive quark creation separately.
14489 IF (MQMASS.NE.0) THEN
14490 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14492 C... Ensure mininimum PT2CR and force creation near threshold.
14493 IF (PT2CR.LT.TMIN*RMQ2) THEN
14495 IF (NTHRES.GT.50) THEN
14496 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14497 & 'massive quark creation. Gave up trying.')
14505 C... Select largest PT2 (brems or creation):
14506 IF (PT2CR.GT.PT2) THEN
14515 C... Compute logarithms for this PT2
14516 TPL=LOG((PT2+VINT(18))/ALAM2)
14517 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14518 WTCRQQ=TPM/LOG(PT2/RMQ2)
14521 C...Evolve joining separately
14523 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14524 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14526 IF (PT2JN.GE.PT2) THEN
14532 C...Loopback if crossed c/b mass thresholds.
14533 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14536 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14541 C...Speed up shower. Skip if higher-PT acceptable branching
14542 C...already found somewhere else.
14543 C...Also finish if below lower cutoff.
14545 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14547 C...Select parton A flavour (massive Q handled above.)
14548 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14552 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14553 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14554 IF(KFLA.EQ.6) KFLA=21
14555 ELSEIF (MJOIN.EQ.1) THEN
14556 C...Tentative joining accept/reject.
14557 WTRAN=PYR(0)*WTJOIN
14560 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14561 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14562 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14563 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14567 C...x*pdf (+ sea/val) at new pT2 for parton B.
14568 IF (KSVCB.LE.0) THEN
14570 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14571 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14573 C...Companion distributions do not evolve.
14576 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14577 KFLC=K(IMI(JS,MJ,1),2)
14579 KSVCC=MAX(-1,IMI(JS,MJ,2))
14580 IF (KSVCB.GE.1) KSVCC=-1
14581 C...x*pdf (+ sea/val) at new pT2 for parton C.
14584 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14586 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14587 WTVETO=WTVETO/XFJ(KFLC)
14588 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14591 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14594 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14598 IF (KSVCA.LE.0) THEN
14600 IF (KFLB.EQ.21) MINT(36)=MJ
14601 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14603 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14605 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14607 WTVETO=WTVETO*XFJ(KFLA)
14608 C...Monte Carlo veto.
14609 IF (WTVETO.LT.PYR(0)) GOTO 200
14610 C...If accept, save PT2 of this joining.
14611 IF (PT2.GT.PT2MX) THEN
14619 C...Exit and continue evolution.
14624 C...Choose z value (still in overestimated range) and corrective weight.
14625 C...Unphysical z will be rejected below when Q2 has is computed.
14628 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14629 C...q -> q + g or q -> q + gamma (already set which).
14630 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14631 IF (KSVCB.LT.0) THEN
14632 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14634 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14635 Z=((1-ZFAC)/(1+ZFAC))**2
14637 WTZ=0.5D0*(1D0+Z**2)
14638 C...Massive weight correction.
14639 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14640 C...Valence quark weight correction (extra sqrt)
14641 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14644 C...NB: MQ>0 not yet implemented. Forced absent above.
14645 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14647 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14648 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14651 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14653 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14654 WTZ=Z**2+(1D0-Z)**2
14655 C...Massive correction
14656 IF (MQMASS.NE.0) THEN
14657 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14658 C...Extra safety margin for light sea quark creation
14659 ELSEIF (KSVCB.LT.0) THEN
14664 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14666 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14667 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14668 WTZ=(1D0-Z*(1D0-Z))**2
14671 C...Derive Q2 from pT2.
14673 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14675 C...Loopback if outside allowed z range for given pT2.
14676 RM2C=PYMASS(KFLC)**2
14677 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14678 IF (PT2ADJ.LT.1D-6) GOTO 230
14680 C...Loopback if nonordered in angle/rapidity.
14681 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14682 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14686 C...Select phi angle of branching at random.
14689 C...Matrix-element corrections for some processes.
14690 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14691 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14692 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14694 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14695 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14697 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14698 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14700 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14701 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14706 C...Parton distributions at new pT2 but old x.
14708 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14709 C...Treat val and cmp separately
14710 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14712 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14714 IF(XFBN.LT.1D-20) THEN
14715 IF(KFLA.EQ.KFLB) THEN
14728 C...Parton distributions at new pT2 and new x.
14731 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14732 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14733 C...q -> q + g: only consider respective sea, val, or cmp content.
14734 IF (KSVCB.LE.0) THEN
14735 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14738 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14742 IF(XFAN.LT.1D-20) THEN
14746 C...If weighting fails continue evolution.
14748 IF (MCRQQ.EQ.0) THEN
14749 WTPDFA=1D0/WTPDF(KFLA)
14750 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14751 ELSEIF(MCRQQ.EQ.1) THEN
14753 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14755 ELSEIF(MCRQQ.EQ.2) THEN
14756 C...Force massive quark creation.
14760 C...Loop back if trial emission fails.
14761 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14762 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14763 IF(WTTOT.LT.0D0) THEN
14764 WRITE(CHWT,'(1P,E12.4)') WTTOT
14765 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14766 ELSEIF(WTTOT.GT.WTACC) THEN
14767 WRITE(CHWT,'(1P,E12.4)') WTTOT
14768 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14769 C...Too high weight: write out as error, but do not update error counter.
14770 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14772 & '(PYPTIS:) Weight '//CHWT//' above unity')
14773 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14774 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14777 & '(PYPTIS:) Weight '//CHWT//' above unity')
14779 C...Useful for debugging but commented out for distribution:
14780 C print*, 'JS, MI',JS, MI
14781 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14782 C print*, 'A -> B C',KFLA, KFLB, KFLC
14784 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14787 C...Save acceptable branching.
14788 IF(PT2.GT.PT2MX) THEN
14801 C----------------------------------------------------------------------
14802 C...MODE= 1: Accept stored shower branching. Update event record etc.
14803 ELSEIF (MODE.EQ.1) THEN
14808 C...Shift down rest of event record to make room for insertion.
14813 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14814 KT1=K(I,4)/MSTU(5)**2
14815 KT2=K(I,5)/MSTU(5)**2
14816 ID1=MOD(K(I,4),MSTU(5))
14817 ID2=MOD(K(I,5),MSTU(5))
14818 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14819 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14820 IF (ID1.GE.IT) ID1=ID1+2
14821 IF (ID2.GE.IT) ID2=ID2+2
14822 IF (IM1.GE.IT) IM1=IM1+2
14823 IF (IM2.GE.IT) IM2=IM2+2
14824 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14825 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14831 MCT(I+2,1)=MCT(I,1)
14832 MCT(I+2,2)=MCT(I,2)
14835 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14836 DO 290 JI=1,MINT(31)
14837 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14838 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14839 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14840 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14841 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14842 C...Also update companion pointers to the present mother.
14843 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14846 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14848 C...Zero entries dedicated for new timelike and mother partons.
14859 C...Define timelike and new mother partons. History.
14866 C...Set mother origin = side.
14867 K(IM,3)=MINT(83)+JS+2
14868 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14870 C...Define colour flow of branching.
14873 C...q -> q + gamma.
14874 IF(K(IT,2).EQ.22) THEN
14879 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14883 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14886 C...qbar -> qbar + g.
14887 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14890 C...qbar -> g + qbar.
14891 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14894 C...g -> g + g; g -> q + qbar..
14895 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14902 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14903 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14904 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14905 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14906 IF(ID1.NE.ID2) THEN
14907 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14908 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14910 IF(K(IT,1).EQ.1) THEN
14914 C...Update IMI and colour tag arrays.
14922 C...If mother flag not yet set for spacelike parton, trace it.
14923 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14924 IF(MINT(51).NE.0) RETURN
14928 C...If mother flag not yet set for timelike parton, trace it.
14929 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14930 IF(MINT(51).NE.0) RETURN
14933 C...Boost recoiling parton to compensate for Q2 scale.
14934 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14935 & (1D0+(1D0+Q2BMX/SHAT)**2)
14937 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14939 C...Define system to be rotated and boosted
14940 C...(not including the 2 just added partons)
14941 C...(but including the docu lines for first interaction)
14942 IMIN=IMISEP(MI-1)+1
14943 IF (MI.EQ.1) IMIN=MINT(83)+5
14946 C...Rotate back system in phi to compensate for subsequent rotation.
14947 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14949 C...Define kinematics of new partons in old frame.
14951 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14952 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14953 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14954 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14956 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14957 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14958 P(IT,5)=SQRT(RM2CMX)
14960 C...Update internal line, now spacelike
14961 P(IS,1)=P(IM,1)-P(IT,1)
14962 P(IS,2)=P(IM,2)-P(IT,2)
14963 P(IS,3)=P(IM,3)-P(IT,3)
14964 P(IS,4)=P(IM,4)-P(IT,4)
14965 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
14966 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
14967 IF (P(IS,5).LT.0D0) THEN
14968 P(IS,5)=-SQRT(ABS(P(IS,5)))
14970 P(IS,5)=SQRT(P(IS,5))
14973 C...Boost entire system and rotate to new frame.
14974 C...(including docu lines)
14975 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14976 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14977 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14978 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14983 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14985 THETA=PYANGL(P(I1,3),P(I1,1))
14986 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14988 C...Global statistics.
14989 MINT(352)=MINT(352)+1
14990 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14991 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14993 C...Add parton with relevant pT scale for timelike shower.
14994 IF (K(IT,2).NE.22) THEN
14997 PTPART(NPART)=SQRT(PT2AMX)
15000 C...Update saved variables.
15001 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15002 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15003 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15004 PT2SAV(JSMX,MIMX)=PT2MX
15009 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15010 C...Gluon reconstructs to quark.
15011 C...Decide whether newly created quark is valence or sea:
15013 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15014 IF(MINT(51).NE.0) RETURN
15016 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15017 C...Quark reconstructs to gluon.
15018 C...Now some guy may have lost his companion. Check.
15020 IF (ICMP.GT.0) THEN
15021 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15022 & //' away. Cannot handle that yet. Giving up.')
15025 ELSEIF(ICMP.LT.0) THEN
15026 C...A sea quark with companion still in BR was reconstructed to a gluon.
15027 C...Companion should now be removed from the beam remnant.
15028 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15031 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
15032 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15033 DO 360 JI=1,MINT(31)
15035 JFL=-K(IMI(JS,JI,1),2)
15036 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15040 NVC(JS,IFL)=NVC(JS,IFL)-1
15042 C...Set gluon IMI(JS,MI,2) = 0.
15044 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15045 C...Quark reconstructing to quark. If sea with companion still in BR
15046 C...then update associated x value.
15047 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15048 IF (IMI(JS,MI,2).LT.0) THEN
15051 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15057 C...If reached this point, normal exit.
15063 C*********************************************************************
15066 C...Generates maximum ME weight in some initial-state showers.
15067 C...Inparameter MECOR: kind of hard scattering process
15068 C...Outparameter WTFF: maximum weight for fermion -> fermion
15069 C... WTGF: maximum weight for gluon/photon -> fermion
15070 C... WTFG: maximum weight for fermion -> gluon/photon
15071 C... WTGG: maximum weight for gluon -> gluon
15073 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15075 C...Double precision and integer declarations.
15076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15077 IMPLICIT INTEGER(I-N)
15078 INTEGER PYK,PYCHGE,PYCOMP
15080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15082 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15083 COMMON/PYINT1/MINT(400),VINT(400)
15084 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15085 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15087 C...Default maximum weight.
15093 C...Select maximum weight by process.
15094 IF(MECOR.EQ.1) THEN
15097 ELSEIF(MECOR.EQ.2) THEN
15105 C*********************************************************************
15108 C...Calculates actual ME weight in some initial-state showers.
15109 C...Inparameter MECOR: kind of hard scattering process
15110 C... IFLCB: flavour combination of branching,
15111 C... 1 for fermion -> fermion,
15112 C... 2 for gluon/photon -> fermion
15113 C... 3 for fermion -> gluon/photon,
15114 C... 4 for gluon -> gluon
15115 C... Q2: Q2 value of shower branching
15116 C... Z: Z value of branching
15117 C...In+outparameter PHIBR: azimuthal angle of branching
15118 C...Outparameter WTME: actual ME weight
15120 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15122 C...Double precision and integer declarations.
15123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15124 IMPLICIT INTEGER(I-N)
15125 INTEGER PYK,PYCHGE,PYCOMP
15127 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15130 COMMON/PYINT1/MINT(400),VINT(400)
15131 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15132 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15134 C...Default output.
15137 C...Define kinematics of shower branching in Mandelstam variables.
15141 UH=Q2-SQM*(1D0-Z)/Z
15143 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15144 IF(MECOR.EQ.1) THEN
15145 IF(IFLCB.EQ.1) THEN
15146 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15147 ELSEIF(IFLCB.EQ.2) THEN
15148 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15151 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15152 ELSEIF(MECOR.EQ.2) THEN
15153 IF(IFLCB.EQ.3) THEN
15154 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15155 ELSEIF(IFLCB.EQ.4) THEN
15156 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15159 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15160 ELSEIF(MECOR.EQ.3) THEN
15161 IF(IFLCB.EQ.2) THEN
15162 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15163 1 (SH**2+2D0*SQM*(SQM-SH))
15170 C*********************************************************************
15173 C...Handles the generation of additional interactions in the new
15174 C...multiple interactions framework.
15175 C...MODE=-1 : Initalize MI from scratch.
15176 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15177 C... Sudakov for PT2, abort if below PT2CUT.
15178 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15179 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15180 C...PT2NOW : Starting (max) PT2 scale for evolution.
15181 C...PT2CUT : Lower limit for evolution.
15182 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15183 C...IFAIL : Status return code.
15184 C... = 0: All is well.
15185 C... < 0: Phase space exhausted, generation to be terminated.
15186 C... > 0: Additional interaction vetoed, but continue evolution.
15188 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15189 C...Double precision and integer declarations.
15190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15191 IMPLICIT INTEGER(I-N)
15192 INTEGER PYK,PYCHGE,PYCOMP
15193 C...Parameter statement for maximum size of showers.
15194 PARAMETER (MAXNUR=1000)
15196 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15197 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15199 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15200 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15201 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15202 COMMON/PYINT1/MINT(400),VINT(400)
15203 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15204 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15205 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15206 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15207 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15208 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15209 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15210 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15211 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15212 COMMON/PYCTAG/NCT,MCT(4000,2)
15213 C...Local arrays and saved variables.
15214 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15216 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15217 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15218 & /PYISMX/,/PYCTAG/
15222 C...Set MI subprocess = QCD 2 -> 2.
15225 C----------------------------------------------------------------------
15226 C...MODE=-1: Initialize from scratch
15227 IF (MODE.EQ.-1) THEN
15228 C...Initialize PT2 array.
15230 C...Initialize list of incoming beams and partons from two sides.
15237 IMI(JS,1,1)=MINT(84)+JS
15239 XMI(JS,1)=VINT(40+JS)
15240 C...Rescale x values to fractions of photon energy.
15241 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15242 C...Hard reset: hard interaction initiators motherless by definition.
15243 K(MINT(84)+JS,3)=2+JS
15244 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15245 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15249 IF (MOD(MSTP(81),10).GE.1) THEN
15250 IF(MSTP(82).LE.1) THEN
15251 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15253 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15254 & VINT(317)/(VINT(318)*VINT(320))
15255 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15257 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15258 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15261 C...Zero entries relating to scatterings beyond the first.
15267 IMISEP(MI)=IMISEP(1)
15272 C...Initialize factors for PDF reshaping.
15274 KFBEAM(JS)=MINT(10+JS)
15275 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15276 KFABM=IABS(KFBEAM(JS))
15277 KFSBM=ISIGN(1,KFBEAM(JS))
15279 C...Zero flavour content of incoming beam particle.
15283 C... Flavour content of baryon.
15284 IF(KFABM.GT.1000) THEN
15285 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15286 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15287 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15288 C... Flavour content of pi+-, K+-.
15289 ELSEIF(KFABM.EQ.211) THEN
15290 KFIVAL(JS,1)=KFSBM*2
15291 KFIVAL(JS,2)=-KFSBM
15292 ELSEIF(KFABM.EQ.321) THEN
15293 KFIVAL(JS,1)=-KFSBM*3
15294 KFIVAL(JS,2)=KFSBM*2
15295 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15298 C...Zero initial valence and companion content.
15303 C...Set up colour line tags starting from hard interaction initiators.
15305 C...Reset colour tag array and colour processing flags.
15306 DO 150 I=IMISEP(0)+1,N
15309 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15310 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15312 C... Consider each side in turn.
15317 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15319 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15321 CALL PYCTTR(I1,KCS,I2)
15322 IF(MINT(51).NE.0) RETURN
15326 C...Range checking for companion quark pdf large-x param.
15327 IF (MSTP(87).LT.0) THEN
15328 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15331 ELSEIF (MSTP(87).GT.4) THEN
15332 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15337 C----------------------------------------------------------------------
15338 C...MODE=0: Generate trial interaction. Return codes:
15339 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15340 C...IFAIL = 0: Additional interaction generated at PT2.
15341 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15342 ELSEIF (MODE.EQ.0) THEN
15343 C...Abolute MI max scale = VINT(62)
15344 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15345 180 IF(MSTP(82).LE.1) THEN
15346 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15347 IF(XT2.LT.VINT(149)) IFAIL=-2
15349 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15352 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15353 & LOG(PYR(0)))-VINT(149)
15356 C...Also exit if below lower limit or if higher trial branching
15358 PT2=0.25D0*VINT(2)*XT2
15359 IF (PT2.LE.PT2CUT) IFAIL=-4
15360 IF (PT2.LE.PT2MX) IFAIL=-5
15361 IF (IFAIL.NE.0) THEN
15365 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15366 VINT(25)=4D0*PT2/VINT(2)
15369 C...Choose tau and y*. Calculate cos(theta-hat).
15370 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15371 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15372 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15374 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15377 C...New: require shat > 1.
15378 IF(TAU*VINT(2).LT.1D0) GOTO 180
15382 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15383 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15384 CALL PYKMAP(2,MYST,PYR(0))
15385 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15387 C...Check that x not used up. Accept or reject kinematical variables.
15388 X1M=SQRT(TAU)*EXP(VINT(22))
15389 X2M=SQRT(TAU)*EXP(-VINT(22))
15390 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15391 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15392 CALL PYSIGH(NCHN,SIGS)
15393 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15394 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15395 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
15397 C...Save if highest PT so far.
15398 IF (PT2.GT.PT2MX) THEN
15404 C----------------------------------------------------------------------
15405 C...MODE=1: Generate and save accepted scattering.
15406 ELSEIF (MODE.EQ.1) THEN
15408 C...Reset K, P, V, and MCT vectors.
15420 C...Choose flavour of reacting partons (and subprocess).
15422 IF (NTRY.GT.50) THEN
15423 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15424 & //'interaction. Giving up!')
15432 ICONMI=ISIG(ICHN,3)
15433 RSIGS=RSIGS-SIGH(ICHN)
15434 IF(RSIGS.LE.0D0) GOTO 230
15437 C...Reassign to appropriate process codes.
15438 230 ISUBMI=ICONMI/10
15439 ICONMI=MOD(ICONMI,10)
15441 C...Choose new quark flavour for annihilation graphs
15442 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15443 SH=VINT(21)*VINT(2)
15444 CALL PYWIDT(21,SH,WDTP,WDTE)
15445 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15446 DO 250 I=1,MDCY(21,3)
15447 KFLF=KFDP(I+MDCY(21,2)-1,1)
15448 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15449 IF(RKFL.LE.0D0) GOTO 260
15451 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15452 IF(KFLF.GE.4) GOTO 240
15453 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15456 ELSEIF(ISUBMI.EQ.53) THEN
15462 C...Final state flavours and colour flow: default values
15469 IF(ISUBMI.EQ.11) THEN
15470 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15472 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15474 ELSEIF(ISUBMI.EQ.12) THEN
15475 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15476 KFL3=ISIGN(KFLF,KFL1)
15480 ELSEIF(ISUBMI.EQ.13) THEN
15481 C...f + fbar -> g + g; th arbitrary
15486 ELSEIF(ISUBMI.EQ.28) THEN
15487 C...f + g -> f + g; th = (p(f)-p(f))**2
15488 IF(KFL1.EQ.21) JS=2
15490 IF(KFL1.EQ.21) KCC=KCC+2
15491 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15492 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15494 ELSEIF(ISUBMI.EQ.53) THEN
15495 C...g + g -> f + fbar; th arbitrary
15496 KCS=(-1)**INT(1.5D0+PYR(0))
15497 KFL3=ISIGN(KFLF,KCS)
15501 ELSEIF(ISUBMI.EQ.68) THEN
15502 C...g + g -> g + g; th arbitrary
15504 KCS=(-1)**INT(1.5D0+PYR(0))
15507 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15508 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15509 & .OR.IABS(KFL4).EQ.5) THEN
15510 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15511 IF (PT2.LE.1.05*RMMAX2) THEN
15512 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15513 & //' created below threshold. Rejected.')
15518 C...Store flavours of scattering.
15526 C...Set flavours and mothers of scattering partons.
15535 K(N+1,3)=MINT(83)+1
15536 K(N+2,3)=MINT(83)+2
15540 C...Store colour connection indices.
15543 IF(KCS.EQ.-1) JC=3-J
15544 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15545 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15546 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15547 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15550 C...Store incoming and outgoing partons in their CM-frame.
15551 SHR=SQRT(VINT(21))*VINT(1)
15554 P(N+2,3)=-0.5D0*SHR
15556 P(N+3,5)=PYMASS(K(N+3,2))
15557 P(N+4,5)=PYMASS(K(N+4,2))
15558 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15562 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15563 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15564 P(N+4,4)=SHR-P(N+3,4)
15567 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15569 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15571 C...Global statistics.
15572 MINT(351)=MINT(351)+1
15573 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15574 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15576 C...Keep track of loose colour ends and information on scattering.
15577 MINT(31)=MINT(31)+1
15579 PT2MI(MINT(36))=PT2
15580 IMISEP(MINT(31))=N+4
15582 IMI(JS,MINT(31),1)=N+JS
15583 IMI(JS,MINT(31),2)=0
15584 XMI(JS,MINT(31))=VINT(40+JS)
15586 C...Update cumulative counters
15587 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15588 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15591 C...Add to list of final state partons
15594 PTPART(NPART+1)=SQRT(PT2)
15595 PTPART(NPART+2)=SQRT(PT2)
15599 NISGEN(1,MINT(31))=0
15600 NISGEN(2,MINT(31))=0
15604 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15605 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15610 C...Finally, assign colour tags to new partons
15612 I1=IMI(JS,MINT(31),1)
15613 I2=IMI(3-JS,MINT(31),1)
15615 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15617 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15619 CALL PYCTTR(I1,KCS,I2)
15620 IF(MINT(51).NE.0) RETURN
15624 C----------------------------------------------------------------------
15625 C...MODE=2: Decide whether quarks in last scattering were valence,
15626 C...companion, or sea.
15627 ELSEIF (MODE.EQ.2) THEN
15631 KFSBM=ISIGN(1,MINT(10+JS))
15632 IFL=K(IMI(JS,MI,1),2)
15634 IF (IABS(IFL).GE.6) THEN
15635 IF (IABS(IFL).EQ.6) THEN
15636 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15640 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15641 C...(Do not include the parton itself in the X rescaling.)
15643 XRSC=X/(VINT(142+JS)+X)
15644 C...Note: XPSVC = x*pdf.
15646 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15650 DO 310 IVC=1,NVC(JS,IFL)
15651 CMP=CMP+XPSVC(IFL,IVC)
15654 C...Decide (Extra factor x cancels in the dvision).
15655 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15657 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15658 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15660 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15661 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15662 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15663 IF(KFIVAL(JS,1).EQ.0) THEN
15664 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15665 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15666 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15667 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15669 C...Count down valence remaining. Do not count current scattering.
15670 DO 340 I1=1,NMI(JS)
15671 IF (I1.EQ.MINT(36)) GOTO 340
15672 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15676 IF(IVNOW.EQ.0) GOTO 330
15679 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15680 IF(KFIVAL(JS,1).EQ.0) THEN
15681 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15684 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15686 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15687 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15691 ELSEIF (RVCS.LE.VAL+SEA) THEN
15692 C...If sea, add opposite sign companion parton. Store X and I.
15693 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15694 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15695 C...Set pointer to companion
15696 IMI(JS,MI,2)=-NVC(JS,-IFL)
15699 C...If companion, decide which one.
15700 IF (NVC(JS,IFL).EQ.0) THEN
15702 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15708 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15709 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15710 C...Find original sea (anti-)quark. Do not consider current scattering.
15712 DO 360 I1=1,NMI(JS)
15713 IF (I1.EQ.MINT(36)) GOTO 360
15714 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15715 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15716 IMI(JS,MI,2)=IMI(JS,I1,1)
15717 IMI(JS,I1,2)=IMI(JS,MI,1)
15720 C...Mark companion "out-kicked".
15721 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15728 C*********************************************************************
15730 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15731 C...Giving the x*f pdf of a companion quark, with its partner at XS,
15732 C...using an approximate gluon density like (1-X)^NPOW/X. The value
15733 C...corresponds to an unrescaled range between 0 and 1-X.
15735 FUNCTION PYFCMP(XC,XS,NPOW)
15737 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15741 C...Parent gluon momentum fraction
15743 IF (Y.GE.1D0) RETURN
15744 C...Common factor (includes factor XC, since PYFCMP=x*f)
15745 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15746 C...Store normalized companion x*f distribution.
15747 IF (NPOW.LE.0) THEN
15748 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15749 ELSEIF (NPOW.EQ.1) THEN
15750 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15751 ELSEIF (NPOW.EQ.2) THEN
15752 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15753 & +3D0*XS*(1D0+XS)*LOG(XS)))
15754 ELSEIF (NPOW.EQ.3) THEN
15755 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15756 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15757 ELSEIF (NPOW.GE.4) THEN
15758 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15759 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15764 C*********************************************************************
15766 C...PYPCMP: Auxiliary to PYPDFU.
15767 C...Giving the momentum integral of a companion quark, with its
15768 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15769 C...The value corresponds to an unrescaled range between 0 and 1-XS.
15771 FUNCTION PYPCMP(XS,NPOW)
15773 DOUBLE PRECISION XS, PYPCMP
15775 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15777 ELSEIF (NPOW.LE.0) THEN
15778 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15779 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15780 ELSEIF (NPOW.EQ.1) THEN
15781 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15782 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15783 ELSEIF (NPOW.EQ.2) THEN
15784 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15785 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15786 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15787 & -3D0*XS*LOG(XS)*(1+XS)))
15788 ELSEIF (NPOW.EQ.3) THEN
15789 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15790 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15791 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15792 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15794 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15795 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15796 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15797 & -6D0*XS*LOG(XS)*(1D0+XS)))
15802 C*********************************************************************
15805 C...Rearranges contents of the HEPEUP commonblock so that
15806 C...mothers precede daughters and daughters of a decay are
15807 C...listed consecutively.
15811 C...Double precision and integer declarations.
15812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15813 IMPLICIT INTEGER(I-N)
15815 C...User process event common block.
15817 PARAMETER (MAXNUP=500)
15818 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15819 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15820 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15821 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15822 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15826 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15827 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15828 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15830 C...Check whether a rearrangement is required.
15833 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15836 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15840 C...Find the new order that particles should have.
15846 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15851 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15852 IF(NNEW.NE.NUP) THEN
15854 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15858 C...Copy old info into temporary storage.
15862 MOTUPT(1,I)=MOTHUP(1,I)
15863 MOTUPT(2,I)=MOTHUP(2,I)
15864 ICOUPT(1,I)=ICOLUP(1,I)
15865 ICOUPT(2,I)=ICOLUP(2,I)
15869 VTIUPT(I)=VTIMUP(I)
15870 SPIUPT(I)=SPINUP(I)
15873 C...Copy info back into HEPEUP in right order.
15876 IDUP(I)=IDUPT(IOLD)
15877 ISTUP(I)=ISTUPT(IOLD)
15881 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15882 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15884 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15886 MOTHUP(1,I)=MOTHUP(2,I)
15889 ICOLUP(1,I)=ICOUPT(1,IOLD)
15890 ICOLUP(2,I)=ICOUPT(2,IOLD)
15892 PUP(J,I)=PUPT(J,IOLD)
15894 VTIMUP(I)=VTIUPT(IOLD)
15895 SPINUP(I)=SPIUPT(IOLD)
15899 c...If incoming particles are massive recalculate to put them massless.
15900 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15901 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15902 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15903 PUP(4,1)=0.5D0*PPLUS
15906 PUP(4,2)=0.5D0*PMINUS
15914 C*********************************************************************
15917 C...Administers the generation of successive final-state showers
15918 C...in external processes.
15920 SUBROUTINE PYADSH(NFIN)
15922 C...Double precision and integer declarations.
15923 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15924 IMPLICIT INTEGER(I-N)
15925 INTEGER PYK,PYCHGE,PYCOMP
15926 C...Parameter statement for maximum size of showers.
15927 PARAMETER (MAXNUR=1000)
15929 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15930 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15931 COMMON/PYCTAG/NCT,MCT(4000,2)
15932 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15933 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15934 COMMON/PYINT1/MINT(400),VINT(400)
15935 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15937 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15939 C...Set primary vertex.
15941 V(MINT(83)+5,J)=0D0
15942 V(MINT(83)+6,J)=0D0
15943 V(MINT(84)+1,J)=0D0
15944 V(MINT(84)+2,J)=0D0
15947 C...Isolate systems of particles with the same mother.
15950 DO 140 I=MINT(84)+3,NFIN
15952 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15959 C...Set production vertices.
15960 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15967 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15970 IF(MSTP(125).GE.1) THEN
15978 C...End loop over systems. Return if no showers to be performed.
15979 IBEG(NSYS+1)=NFIN+1
15980 IF(MSTP(71).LE.0) RETURN
15982 C...Loop through systems of particles; check that sensible size.
15984 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15985 IF(MINT(35).LE.1) THEN
15986 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15988 ELSEIF(NSIZ.LE.1) THEN
15989 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15991 ELSEIF(NSIZ.GT.80) THEN
15992 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15997 C...Save status codes and daughters of showering particles; reset them.
16004 IF(K(I,1).GT.10) THEN
16006 IF(KSAV(II,1).EQ.14) K(I,1)=3
16008 IF(KSAV(II,1).LE.10) THEN
16009 ELSEIF(K(I,1).EQ.1) THEN
16015 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16016 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16017 K(I,4)=K(I,4)-KSAV(II,4)
16018 K(I,5)=K(I,5)-KSAV(II,5)
16021 PSUM(J)=PSUM(J)+P(I,J)
16025 C...Perform shower.
16026 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16028 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16030 IF(MINT(35).LE.1) THEN
16032 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16034 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16037 C...For external processes, first call, also ISR partons radiate.
16038 C...Can use existing PYPART list, removing partons that radiate later.
16039 ELSEIF(ISYS.EQ.1) THEN
16042 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16044 IPART(NPARTN)=IPART(II)
16045 PTPART(NPARTN)=PTPART(II)
16049 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16051 C...For subsequent calls use the systems excluded above.
16057 PTPART(II)=0.5D0*QMAX
16059 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16062 C...Look up showered copies of original showering particles.
16066 C...Particles without daughters need not be studied.
16067 IF(KSAV(II,1).LE.10) GOTO 260
16068 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16069 ELSEIF(K(I,1).EQ.11) THEN
16070 190 IMV=MOD(K(IMV,4),MSTU(5))
16071 IF(K(IMV,1).EQ.11) GOTO 190
16073 KDA1=MOD(K(I,4),MSTU(5))
16075 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16077 KDA2=MOD(K(I,5),MSTU(5))
16079 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16082 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16085 KDA1=MOD(K(I3,4),MSTU(5))
16087 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16089 KDA2=MOD(K(I3,5),MSTU(5))
16091 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16097 C...Restore daughter info of original partons to showered copies.
16098 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16099 IF(KSAV(II,1).LE.10) THEN
16100 ELSEIF(K(I,1).EQ.1) THEN
16101 K(IMV,4)=KSAV(II,4)
16102 K(IMV,5)=KSAV(II,5)
16104 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16105 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16108 C...Reset mother info of existing daughters to showered copies.
16109 DO 210 I3=IBEG(ISYS+1),NFIN
16110 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16111 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16112 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16113 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16117 C...Boost all original daughters to new frame of showered copy.
16118 C...Also update their colour tags.
16121 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16123 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16125 BETA(J)=FAC*BETA(J)
16127 DO 250 I3=IBEG(ISYS+1),NFIN
16130 IF(MSTP(128).LE.0) THEN
16131 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16132 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16134 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16135 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16136 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16139 IF(IMO.EQ.IMV) THEN
16140 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16141 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16142 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16143 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16151 C...End of loop over showering systems
16157 C*********************************************************************
16160 C...Interface to UPVETO, which allows user to veto event generation
16161 C...on the parton level, after parton showers but before multiple
16162 C...interactions, beam remnants and hadronization is added.
16164 SUBROUTINE PYVETO(IVETO)
16166 C...All real arithmetic in double precision.
16167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16168 C...Three Pythia functions return integers, so need declaring.
16169 INTEGER PYK,PYCHGE,PYCOMP
16171 C...PYTHIA commonblocks.
16172 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16173 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16175 COMMON/PYINT1/MINT(400),VINT(400)
16176 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16177 C...HEPEVT commonblock.
16178 PARAMETER (NMXHEP=4000)
16179 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16180 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16181 DOUBLE PRECISION PHEP,VHEP
16184 DIMENSION IRESO(100)
16186 C...Define longitudinal boost from initiator rest frame to cm frame.
16187 IF(MINT(35).EQ.3) THEN
16188 C...The last frame is different depending upon old and new shower
16192 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16193 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16196 C... Reset counters.
16201 C...Oth pass: identify beam and incoming partons
16202 DO 140 I=MINT(83)+1,MINT(83)+6
16204 C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
16205 IF(K(I,2).EQ.94) THEN
16215 IF(ISTORE.EQ.1) THEN
16216 C...Copy parton info, boosting momenta along z axis to cm frame.
16222 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16223 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16229 C...Store one mother. Rest of history and vertex info zeroed.
16241 C...First pass: identify final locations of resonances
16242 C...and of their daughters before showering.
16243 DO 150 I=MINT(84)+3,N
16247 C...Skip shower CM frame documentation lines.
16248 IF(K(I,2).EQ.94) THEN
16250 C... Store a new intermediate product, when mother in documentation.
16251 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16252 & K(I,3).LE.MINT(84)) THEN
16260 C... Store a new intermediate product, when mother in main section.
16261 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16262 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16268 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
16271 IF(ISTORE.EQ.1) THEN
16272 C...Copy parton info, boosting momenta along z axis to cm frame.
16277 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16278 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16280 C...Store one mother. Rest of history and vertex info zeroed.
16292 C...Second pass: identify current set of "final" partons.
16293 DO 200 I=MINT(84)+3,N
16297 C...Store a final parton.
16298 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16302 C..Trace it back through shower, to check if from documented particle.
16306 IF(IHIST.GT.MINT(84)) THEN
16307 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16309 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16313 IF(IMOTH.EQ.0) GOTO 160
16314 ELSEIF(IHIST.LE.4) THEN
16315 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16324 IF(ISTORE.EQ.1) THEN
16325 C...Copy parton info, boosting momenta along z axis to cm frame.
16330 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16331 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16333 C...Store one mother. Rest of history and vertex info zeroed.
16345 C...Call user-written routine to decide whether to keep events.
16350 C*********************************************************************
16353 C...Allows resonances to decay (including parton showers for hadronic
16356 SUBROUTINE PYRESD(IRES)
16358 C...Double precision and integer declarations.
16359 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16360 IMPLICIT INTEGER(I-N)
16361 INTEGER PYK,PYCHGE,PYCOMP
16362 C...Parameter statement to help give large particle numbers.
16363 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16364 &KEXCIT=4000000,KDIMEN=5000000)
16365 C...Parameter statement for maximum size of showers.
16366 PARAMETER (MAXNUR=1000)
16368 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16370 COMMON/PYCTAG/NCT,MCT(4000,2)
16371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16373 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16374 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16375 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16376 COMMON/PYINT1/MINT(400),VINT(400)
16377 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16378 COMMON/PYINT4/MWID(500),WIDS(500,5)
16379 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16380 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
16381 C...Local arrays and complex and character variables.
16382 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16383 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16384 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16385 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16386 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16387 COMPLEX FGK,HA(6,6),HC(6,6)
16389 CHARACTER CODE*9,MASS*9
16391 C...The F, Xi and Xj functions of Gunion and Kunszt
16392 C...(Phys. Rev. D33, 665, plus errata from the authors).
16393 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16394 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16395 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16396 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16397 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16398 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16399 &2D0*(D34/D56+D56/D34))
16401 C...Some general constants.
16404 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16408 GMMZ=PMAS(23,1)*PMAS(23,2)
16410 GMMW=PMAS(24,1)*PMAS(24,2)
16413 C...Boost and rotate to rest frame of incoming partons,
16414 C...to get proper amount of smearing of decay angles.
16418 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
16419 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
16420 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
16421 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
16422 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
16423 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
16424 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
16425 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
16426 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
16429 C...Reset original resonance configuration.
16434 C...Define initial one, two or three objects for subprocess.
16438 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16439 IREF(1,1)=MINT(84)+2+ISET(ISUB)
16440 IREF(1,4)=MINT(83)+6+ISET(ISUB)
16442 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16443 IREF(1,1)=MINT(84)+1+ISET(ISUB)
16444 IREF(1,2)=MINT(84)+2+ISET(ISUB)
16445 IREF(1,4)=MINT(83)+5+ISET(ISUB)
16446 IREF(1,5)=MINT(83)+6+ISET(ISUB)
16448 ELSEIF(ISET(ISUB).EQ.5) THEN
16449 IREF(1,1)=MINT(84)+3
16450 IREF(1,2)=MINT(84)+4
16451 IREF(1,3)=MINT(84)+5
16452 IREF(1,4)=MINT(83)+7
16453 IREF(1,5)=MINT(83)+8
16454 IREF(1,6)=MINT(83)+9
16458 C...Define original resonance for odd cases.
16461 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16463 IF(IHDEC.EQ.1) ISUB=3
16465 IREF(1,4)=K(IRES,3)
16467 IF(IREF(1,4).GT.MINT(84)) THEN
16468 110 ITMPMO=IREF(1,4)
16469 IF(K(ITMPMO,2).EQ.94) THEN
16470 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16471 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16472 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16474 C...Explicitly check that reference particle exists, otherwise stop recursion
16475 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
16476 IREF(1,4)=K(ITMPMO,3)
16481 IF(IREF(1,4).GT.MINT(84)) THEN
16484 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16485 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16488 EMATCH=ABS(P(II,4)-P(IREF14,4))
16495 C...Check if initial resonance has been moved (in resonance + jet).
16497 IF(IREF(1,JT).GT.0) THEN
16498 IF(K(IREF(1,JT),1).GT.10) THEN
16499 KFA=IABS(K(IREF(1,JT),2))
16500 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16501 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16502 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16503 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16504 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16506 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16507 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16509 DO 130 I=IREF(1,JT)+1,N
16510 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16513 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16514 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16515 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16516 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16518 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16519 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16524 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16525 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16531 C...Set decay vertex for initial resonances
16534 V(IREF(1,JT),I)=0D0
16538 C...Loop over decay history.
16544 IF(IREF(IP,2).EQ.0) JTMAX=1
16545 IF(IREF(IP,3).NE.0) JTMAX=3
16549 C...Check for Higgs which appears as decay product of user-process.
16552 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16554 IF(IHDEC.EQ.1) ISUB=3
16557 C...Start treatment of one, two or three resonances in parallel.
16569 C...Check whether particle can/is allowed to decay.
16570 IF(ID.EQ.0) GOTO 330
16573 IF(MWID(KCA).EQ.0) GOTO 330
16574 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16575 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16576 & KFA.EQ.18) IT4=IT4+1
16577 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16578 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16580 C...Choose lifetime and determine decay vertex.
16581 IF(K(ID,1).EQ.5) THEN
16583 ELSEIF(K(ID,1).NE.4) THEN
16584 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16587 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16590 C...Determine whether decay allowed or not.
16592 IF(MSTJ(22).EQ.2) THEN
16593 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16594 ELSEIF(MSTJ(22).EQ.3) THEN
16595 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16596 ELSEIF(MSTJ(22).EQ.4) THEN
16597 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16598 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16600 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16605 C...Info for selection of decay channel: sign, pairings.
16606 IF(KCHG(KCA,3).EQ.0) THEN
16609 IPM=(5-ISIGN(1,K(ID,2)))/2
16612 IF(JTMAX.EQ.2) THEN
16613 KFB=IABS(K(IREF(IP,3-JT),2))
16614 ELSEIF(JTMAX.EQ.3) THEN
16616 KFB=IABS(K(IREF(IP,JT2),2))
16617 IF(KFB.NE.KFA) THEN
16618 JT2=JT+2-3*((JT+1)/3)
16619 KFB=IABS(K(IREF(IP,JT2),2))
16623 C...Select decay channel.
16624 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16625 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16626 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16627 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16628 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16629 IF(WDTE0S.LE.0D0) GOTO 330
16633 IDC=IDL+MDCY(KCA,2)-1
16634 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16635 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16636 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16638 C...Read out flavours and colour charges of decay channel chosen.
16639 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16640 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16641 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16642 KFC1A=PYCOMP(IABS(KFL1(JT)))
16643 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16644 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16645 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16646 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16647 KFC2A=PYCOMP(IABS(KFL2(JT)))
16648 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16649 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16650 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16651 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16653 IF(KFL3(JT).NE.0) THEN
16654 KFC3A=PYCOMP(IABS(KFL3(JT)))
16655 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16656 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16657 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16660 C...Set/save further info on channel.
16662 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16664 HGZ(JT,1)=VINT(111)
16665 HGZ(JT,2)=VINT(112)
16666 HGZ(JT,3)=VINT(114)
16669 C...Select masses; to begin with assume resonances narrow.
16674 KFLW=IABS(KFL1(JT))
16676 ELSEIF(I.EQ.2) THEN
16677 KFLW=IABS(KFL2(JT))
16679 ELSEIF(I.EQ.3) THEN
16680 IF(KFL3(JT).EQ.0) GOTO 220
16681 KFLW=IABS(KFL3(JT))
16684 P(N+I,5)=PMAS(KCW,1)
16686 C...This prevents SUSY/t particles from becoming too light.
16687 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16688 PMMN(I)=PMAS(KCW,1)
16689 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16690 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16691 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16692 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16693 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16694 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16695 PMMN(I)=MIN(PMMN(I),PMSUM)
16699 ELSEIF(KFLW.EQ.6) THEN
16700 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16704 C...Check which two out of three are widest.
16707 PWID1=PMAS(KFC1A,2)
16708 PWID2=PMAS(KFC2A,2)
16709 KFLW1=IABS(KFL1(JT))
16710 KFLW2=IABS(KFL2(JT))
16711 IF(KFL3(JT).NE.0) THEN
16712 PWID3=PMAS(KFC3A,2)
16713 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16716 KFLW1=IABS(KFL3(JT))
16717 ELSEIF(PWID3.GT.PWID2) THEN
16720 KFLW2=IABS(KFL3(JT))
16724 C...If all narrow then only check that masses consistent.
16725 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16726 & PWID2.LT.PARP(41))) THEN
16728 C....Handle near degeneracy cases.
16729 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16730 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16731 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16732 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16736 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16737 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16740 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16741 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16746 C...For three wide resonances select narrower of three
16747 C...according to BW decoupled from rest.
16750 IF(KFL3(JT).NE.0) THEN
16751 IWID3=6-IWID1-IWID2
16752 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16756 P(N+IWID3,5)=PYMASS(KFLW3)
16757 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16758 PMTOT=PMTOT-P(N+IWID3,5)
16760 C...Select other two correlated within remaining phase space.
16764 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16765 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16766 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16771 CKIN(49)=PMMN(IWID1)
16772 CKIN(50)=PMMN(IWID2)
16773 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16778 IF(MINT(51).EQ.1) GOTO 720
16781 C...Begin fill decay products, with colour flow for coloured objects.
16786 C...Three-body decays
16787 IF(KFL3(JT).NE.0) THEN
16804 C...Generate kinematics (default is flat)
16807 C...Set generic colour flows whenever unambiguous,
16808 C...(independently of the order of the decay products)
16809 C...Sum up total colour content
16818 IF (KCQ(J).EQ.-1) THEN
16821 ELSEIF (KCQ(J).EQ.1) THEN
16824 ELSEIF (KCQ(J).EQ.2) THEN
16830 C...Set color flow for generic 1 -> N processes (N arbitrary)
16831 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
16832 C...All singlets: do nothing
16834 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
16835 C...Two octets, zero triplets, n singlets:
16836 IF (KCQ(0).EQ.2) THEN
16838 K(ID,4)=K(ID,4)+IOCT(2)
16839 K(ID,5)=K(ID,5)+IOCT(2)
16841 K(IOCT(2),4)=MSTU(5)*ID
16842 K(IOCT(2),5)=MSTU(5)*ID
16843 MCT(IOCT(2),1)=MCT(ID,1)
16844 MCT(IOCT(2),2)=MCT(ID,2)
16846 C...1 -> 8 + 8 + n(1)
16848 K(IOCT(1),4)=MSTU(5)*IOCT(2)
16849 K(IOCT(1),5)=MSTU(5)*IOCT(2)
16851 K(IOCT(2),4)=MSTU(5)*IOCT(1)
16852 K(IOCT(2),5)=MSTU(5)*IOCT(1)
16861 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
16862 C...Two triplets, zero octets, n singlets.
16863 IF (KCQ(0).EQ.1) THEN
16865 K(ID,4)=K(ID,4)+ITRI(2)
16867 K(ITRI(2),4)=MSTU(5)*ID
16868 MCT(ITRI(2),1)=MCT(ID,1)
16869 ELSEIF (KCQ(0).EQ.-1) THEN
16870 C...3bar -> 3bar + n(1)
16871 K(ID,5)=K(ID,5)+IANT(2)
16873 K(IANT(2),5)=MSTU(5)*ID
16874 MCT(IANT(2),2)=MCT(ID,2)
16876 C...1 -> 3 + 3bar + n(1)
16878 K(ITRI(1),4)=MSTU(5)*IANT(1)
16880 K(IANT(1),5)=MSTU(5)*ITRI(1)
16886 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
16887 C...Two triplets, one octet, n singlets.
16888 IF (KCQ(0).EQ.2) THEN
16889 C...8 -> 3 + 3bar + n(1)
16890 K(ID,4)=K(ID,4)+ITRI(1)
16891 K(ID,5)=K(ID,5)+IANT(1)
16893 K(ITRI(1),4)=MSTU(5)*ID
16895 K(IANT(1),5)=MSTU(5)*ID
16896 MCT(ITRI(1),1)=MCT(ID,1)
16897 MCT(IANT(1),2)=MCT(ID,2)
16898 ELSEIF (KCQ(0).EQ.1) THEN
16899 C...3 -> 8 + 3 + n(1)
16900 K(ID,4)=K(ID,4)+IOCT(1)
16902 K(IOCT(1),4)=MSTU(5)*ID
16903 K(IOCT(1),5)=MSTU(5)*ITRI(2)
16905 K(ITRI(2),4)=MSTU(5)*IOCT(1)
16906 MCT(IOCT(1),1)=MCT(ID,1)
16910 ELSEIF (KCQ(0).EQ.-1) THEN
16911 C...3bar -> 8 + 3bar + n(1)
16912 K(ID,5)=K(ID,5)+IOCT(1)
16914 K(IOCT(1),5)=MSTU(5)*ID
16915 K(IOCT(1),4)=MSTU(5)*IANT(2)
16917 K(IANT(2),5)=MSTU(5)*IOCT(1)
16918 MCT(IOCT(1),2)=MCT(ID,2)
16923 C...1 -> 3 + 3bar + 8 + n(1)
16925 K(ITRI(1),4)=MSTU(5)*IOCT(1)
16927 K(IOCT(1),5)=MSTU(5)*ITRI(1)
16928 K(IOCT(1),4)=MSTU(5)*IANT(1)
16930 K(IANT(1),5)=MSTU(5)*IOCT(1)
16938 CPS-- End of generic cases
16939 C...(could three octets also be handled?)
16940 C...(could (some of) the RPV cases be made generic as well?)
16942 C...Special cases (= old treatment)
16943 C...Set colour flow for t -> W + b + Z.
16944 ELSEIF(KFA.EQ.6) THEN
16947 IF(KCQM(JT).EQ.-1) ISID=5
16949 K(ID,ISID)=K(ID,ISID)+IDAU
16950 K(IDAU,ISID)=MSTU(5)*ID
16952 C...Set colour flow in three-body decays - programmed as special cases.
16954 ELSEIF(KFC2A.LE.6) THEN
16958 IF(KFL2(JT).LT.0) ISID=5
16959 K(N+2,ISID)=MSTU(5)*(N+3)
16960 K(N+3,9-ISID)=MSTU(5)*(N+2)
16961 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16962 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16963 & .AND.KFL3(JT).NE.0) THEN
16964 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16965 C...3-body decays of squarks to colour singlets plus one quark
16966 IF (KQSUMA.EQ.1) THEN
16969 IF (KCQ1(JT).NE.0) IQ=1
16970 IF (KCQ2(JT).NE.0) IQ=2
16971 IF (KCQ3(JT).NE.0) IQ=3
16973 IF (K(N+IQ,2).LT.0) ISID=5
16975 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16976 K(N+IQ,ISID)=MSTU(5)*ID
16979 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
16984 IF(KFL2(JT).LT.0) ISID=5
16985 K(N+1,ISID)=MSTU(5)*(N+2)
16986 K(N+1,9-ISID)=MSTU(5)*(N+3)
16987 K(N+2,ISID)=MSTU(5)*(N+1)
16988 K(N+3,9-ISID)=MSTU(5)*(N+1)
16989 ELSEIF(KFA.EQ.KSUSY1+21) THEN
16993 IF(KFL2(JT).LT.0) ISID=5
16994 K(ID,ISID)=K(ID,ISID)+(N+2)
16995 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
16996 K(N+2,ISID)=MSTU(5)*ID
16997 K(N+3,9-ISID)=MSTU(5)*ID
17000 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17001 & IABS(KCQ2(JT)).EQ.1) THEN
17005 IF(KFL2(JT).LT.0) ISID=5
17006 K(N+2,ISID)=MSTU(5)*(N+3)
17007 K(N+3,9-ISID)=MSTU(5)*(N+2)
17012 C...Set colour flow in three-body decays with baryon number violation.
17013 C...Neutralino and chargino decays first.
17014 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17015 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17016 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17017 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17018 C...Insert junction to keep track of colours.
17019 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17020 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17021 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17022 C...Set special junction codes:
17026 C...Order decay products by invariant mass. (will be used in PYSTRF).
17027 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)-
17028 & P(N+1,3)*P(N+2,3)
17029 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)-
17030 & P(N+1,3)*P(N+3,3)
17031 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)-
17032 & P(N+2,3)*P(N+3,3)
17033 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17034 K(N+4,4)=N+3+K(N+4,4)
17035 K(N+4,5)=N+1+MSTU(5)*(N+2)
17036 ELSEIF(PM13.LT.PM23) THEN
17037 K(N+4,4)=N+2+K(N+4,4)
17038 K(N+4,5)=N+1+MSTU(5)*(N+3)
17040 K(N+4,4)=N+1+K(N+4,4)
17041 K(N+4,5)=N+2+MSTU(5)*(N+3)
17047 C...Connect daughters to junction.
17051 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17053 C...Particle counter should be stepped up one extra for junction.
17057 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17058 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17059 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17060 C...Insert junction to keep track of colours.
17061 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17062 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17063 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17074 C...Start by connecting all daughters to junction.
17075 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17076 C...Only consider colour topologies with off shell resonances.
17077 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17078 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17079 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17080 IF (RMGLU-RMQ1.LT.RMRES) THEN
17081 C...Calculate propagators for each colour topology.
17082 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17083 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17084 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17088 CTMSUM=CTMSUM+CTM2(II-N)
17090 CTMSUM=PYR(0)*CTMSUM
17091 C...Select colour topology J, with most off shell least likely.
17094 CTMSUM=CTMSUM-CTM2(J)
17095 IF (CTMSUM.GT.0D0) GOTO 300
17096 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17097 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17098 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17099 C...The other gluino colour is connected to junction
17100 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17102 K(N+4,4)=K(N+4,4)+ID
17103 C...Lastly, connect junction to remaining daughters.
17104 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17105 C...Particle counter should be stepped up one extra for junction.
17109 C...Update particle counter.
17112 C...2) Everything else two-body decay.
17114 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17119 C...First set colour flow as if mother colour singlet.
17120 IF(KCQ1(JT).NE.0) THEN
17122 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17123 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17125 IF(KCQ2(JT).NE.0) THEN
17127 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17128 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17130 C...Then redirect colour flow if mother (anti)triplet.
17131 IF(KCQM(JT).EQ.0) THEN
17132 ELSEIF(KCQM(JT).NE.2) THEN
17134 IF(KCQM(JT).EQ.-1) ISID=5
17136 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17137 K(ID,ISID)=K(ID,ISID)+IDAU
17138 K(IDAU,ISID)=MSTU(5)*ID
17139 C...Then redirect colour flow if mother octet.
17140 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17142 IF(KCQ1(JT).EQ.0) IDAU=N
17143 K(ID,4)=K(ID,4)+IDAU
17144 K(ID,5)=K(ID,5)+IDAU
17145 K(IDAU,4)=MSTU(5)*ID
17146 K(IDAU,5)=MSTU(5)*ID
17149 IF(KCQ1(JT).EQ.-1) ISID=5
17150 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17151 K(ID,ISID)=K(ID,ISID)+(N-1)
17152 K(ID,9-ISID)=K(ID,9-ISID)+N
17153 K(N-1,ISID)=MSTU(5)*ID
17154 K(N,9-ISID)=MSTU(5)*ID
17157 C...Insert junction
17158 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17160 C...~q* mother: type 3 junction. ~q mother: type 4.
17161 ITJUNC(JT)=(7+KCQM(JT))/2
17162 C...Specify junction KF and set colour flow from junction
17166 C...Junction type encoded together with mother:
17167 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17168 K(N,5)=N-1+MSTU(5)*(N-2)
17169 C...Zero P and V for junction (V filled later)
17174 C...Set colour flow from mother to junction
17175 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17176 C...Set colour flow from daughters to junction
17180 C...(Anti-)colour mother is junction.
17181 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17186 C...End loop over resonances for daughter flavour and mass selection.
17188 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17190 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17191 & KFL1(JT).EQ.0) THEN
17192 WRITE(CODE,'(I9)') K(ID,2)
17193 WRITE(MASS,'(F9.3)') P(ID,5)
17194 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17195 & CODE//' with mass'//MASS)
17201 C...Check for allowed combinations. Skip if no decays.
17202 IF(JTMAX.EQ.1) THEN
17203 IF(KDCY(1).EQ.0) GOTO 710
17204 ELSEIF(JTMAX.EQ.2) THEN
17205 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17206 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17207 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17208 ELSEIF(JTMAX.EQ.3) THEN
17209 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17210 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17211 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17212 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17213 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17214 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17215 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17218 C...Special case: matrix element option for Z0 decay to quarks.
17219 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17220 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17222 C...Check consistency of MSTJ options set.
17223 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17225 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17228 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17230 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17235 C...Select alpha_strong behaviour.
17238 MSTU(111)=MSTJ(108)
17239 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17241 PARU(112)=PARJ(121)
17242 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17244 C...Find axial fraction in total cross section for scalar gluon model.
17246 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17247 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17248 POLL=1D0-PARJ(131)*PARJ(132)
17249 SFF=1D0/(16D0*XW*XW1)
17250 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17251 & (PARJ(123)*PARJ(124))**2)
17252 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17254 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17255 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17256 & (PARJ(132)-PARJ(131)))
17259 QF=KCHG(KFLC,1)/3D0
17261 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17262 & 1D0-(2D0*PMQ/P(ID,5))**2))
17263 VF=SIGN(1D0,QF)-4D0*QF*XW
17264 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17265 & VF**2*HF1W)+VQ**3*HF1W
17266 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17269 C...Choice of jet configuration.
17270 CALL PYXJET(P(ID,5),NJET,CUT)
17274 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17275 ELSEIF(NJET.EQ.3) THEN
17276 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17281 C...Fill jet configuration; return if incorrect kinematics.
17283 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17284 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17285 ELSEIF(NJET.EQ.2) THEN
17286 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17287 ELSEIF(NJET.EQ.3) THEN
17288 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17289 ELSEIF(KFLN.EQ.21) THEN
17290 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17293 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17296 IF(MSTU(24).NE.0) THEN
17303 C...Angular orientation according to matrix element.
17304 IF(MSTJ(106).EQ.1) THEN
17305 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17306 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17308 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17309 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17312 C...Boost partons to Z0 rest frame.
17313 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17314 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17316 C...Mark decayed resonance and add documentation lines,
17318 IDOC=MINT(83)+MINT(4)
17320 I1=MINT(83)+MINT(4)+1
17322 IF(MSTP(128).GE.1) K(I,3)=ID
17323 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17334 C...Generate parton shower.
17335 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17336 CALL PYSHOW(N-1,N,P(ID,5))
17337 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17341 PTPART(1)=0.5D0*P(ID,5)
17342 PTPART(2)=PTPART(1)
17344 IF(K(N-1,2).GT.0) THEN
17351 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17354 C... End special case for Z0: skip ahead.
17360 C...Order incoming partons and outgoing resonances.
17361 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17364 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17365 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17366 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17367 ILIN(2)=2*MINT(84)+3-ILIN(1)
17369 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17373 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17374 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17375 IAKIPD=IABS(K(IREF(IP,IORD),2))
17376 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17377 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17379 C...Order decay products of resonances.
17380 DO 370 JT=IORD,3-IORD,3-2*IORD
17381 IF(KDCY(JT).EQ.0) THEN
17382 ILIN(IMAX+1)=NSD(JT)
17384 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
17385 ILIN(IMAX+1)=N+2*JT-1
17386 ILIN(IMAX+2)=N+2*JT
17388 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17389 K(N+2*JT,2)=K(NSD(JT)+2,2)
17391 ILIN(IMAX+1)=N+2*JT
17393 ILIN(IMAX+2)=N+2*JT-1
17395 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17396 K(N+2*JT,2)=K(NSD(JT)+2,2)
17400 C...Find charge, isospin, left- and righthanded couplings.
17405 KFA=IABS(K(ILIN(I),2))
17406 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
17407 COUP(I,1)=KCHG(KFA,1)/3D0
17408 COUP(I,2)=(-1)**MOD(KFA,2)
17409 COUP(I,4)=-2D0*COUP(I,1)*XWV
17410 COUP(I,3)=COUP(I,2)+COUP(I,4)
17413 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17414 IF(ISUB.EQ.22) THEN
17417 IF(I.EQ.5) I1=3-IORD
17420 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
17421 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
17422 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
17427 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17428 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
17429 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
17430 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
17432 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
17436 C...Select angular orientation type - Z'/W' only.
17438 IF(ISUB.EQ.141) THEN
17439 IF(PYR(0).LT.PARU(130)) MZPWP=1
17441 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
17442 IAKIR=IABS(K(IREF(2,2),2))
17443 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17444 IF(IAKIR.LE.20) MZPWP=2
17446 IF(IP.GE.3) MZPWP=2
17447 ELSEIF(ISUB.EQ.142) THEN
17448 IF(PYR(0).LT.PARU(136)) MZPWP=1
17450 IAKIR=IABS(K(IREF(2,2),2))
17451 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17452 IF(IAKIR.LE.20) MZPWP=2
17454 IF(IP.GE.3) MZPWP=2
17457 C...Select random angles (begin of weighting procedure).
17458 430 DO 440 JT=1,JTMAX
17459 IF(KDCY(JT).EQ.0) GOTO 440
17460 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
17461 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
17462 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
17465 CTHE(JT)=2D0*PYR(0)-1D0
17466 PHI(JT)=PARU(2)*PYR(0)
17470 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
17471 C...Construct massless four-vectors.
17480 IF(KDCY(JT).EQ.0) GOTO 470
17482 P(N+2*JT-1,3)=0.5D0*P(ID,5)
17483 P(N+2*JT-1,4)=0.5D0*P(ID,5)
17484 P(N+2*JT,3)=-0.5D0*P(ID,5)
17485 P(N+2*JT,4)=0.5D0*P(ID,5)
17486 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
17487 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17490 C...Store incoming and outgoing momenta, with random rotation to
17491 C...avoid accidental zeroes in HA expressions.
17495 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
17496 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
17497 P(N+4+I,5)=P(ILIN(I),5)
17499 P(N+4+I,J)=P(ILIN(I),J)
17502 500 THERR=ACOS(2D0*PYR(0)-1D0)
17503 PHIRR=PARU(2)*PYR(0)
17504 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
17506 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
17507 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
17514 C...Calculate internal products.
17515 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
17516 & ISUB.EQ.142) THEN
17517 DO 540 I1=IMIN,IMAX-1
17518 DO 530 I2=I1+1,IMAX
17519 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
17520 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
17521 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
17522 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
17523 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
17524 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
17525 HC(I1,I2)=CONJG(HA(I1,I2))
17526 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
17527 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
17528 HA(I2,I1)=-HA(I1,I2)
17529 HC(I2,I1)=-HC(I1,I2)
17534 C...Calculate four-products.
17541 DO 580 I1=IMIN,IMAX-1
17542 DO 570 I2=I1+1,IMAX
17543 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
17544 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
17545 PKK(I2,I1)=PKK(I1,I2)
17551 KFAGM=IABS(IREF(IP,7))
17552 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
17553 C...Isotropic decay selected by user.
17557 ELSEIF(JTMAX.EQ.3) THEN
17558 C...Isotropic decay when three mother particles.
17562 ELSEIF(IT4.GE.1) THEN
17563 C... Isotropic decay t -> b + W etc for 4th generation q and l.
17567 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
17568 & IREF(IP,7).EQ.36) THEN
17569 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
17570 C...CP-odd case added by Kari Ertresvag Myklevoll.
17571 C...Now also with mixed Higgs CP-states
17573 IF(IP.EQ.1) WTMAX=SH**2
17574 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
17575 KFA=IABS(K(IREF(IP,1),2))
17576 KFT=IABS(K(IREF(IP,2),2))
17578 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
17579 & MSTP(25).GE.3) THEN
17580 C...For mixed CP states need epsilon product.
17597 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17598 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17599 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17600 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17601 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17602 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17603 & P22*P30*P41+P13*P22*P31*P40
17604 C...For mixed CP states need gauge boson masses.
17605 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17606 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17607 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17608 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17613 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
17614 KFLF1A=IABS(KFL1(1))
17615 EF1=KCHG(KFLF1A,1)/3D0
17616 AF1=SIGN(1D0,EF1+0.1D0)
17617 VF1=AF1-4D0*EF1*XWV
17618 KFLF2A=IABS(KFL1(2))
17619 EF2=KCHG(KFLF2A,1)/3D0
17620 AF2=SIGN(1D0,EF2+0.1D0)
17621 VF2=AF2-4D0*EF2*XWV
17622 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17623 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17626 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17627 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17628 ELSEIF(MSTP(25).LE.2) THEN
17630 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17631 & -2*PKK(3,4)*PKK(5,6)
17632 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17633 & (PKK(3,4)*PKK(5,6))
17634 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17635 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17637 C...Mixed CP states.
17638 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17639 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17640 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17641 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17642 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17643 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17644 & +PKK(3,4)*PKK(5,6)
17645 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17646 & +VA12AS*PKK(3,4)*PKK(5,6)
17647 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17648 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17649 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17650 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17654 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
17655 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17658 WT=16D0*PKK(3,5)*PKK(4,6)
17659 ELSEIF(MSTP(25).LE.2) THEN
17661 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17662 & -2*PKK(3,4)*PKK(5,6)
17663 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17664 & (PKK(3,4)*PKK(5,6))
17665 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17666 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17668 C...Mixed CP states.
17669 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17670 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17671 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17672 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17673 & +PKK(3,4)*PKK(5,6)
17674 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17675 & +PKK(3,4)*PKK(5,6)
17676 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17677 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17678 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17679 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17682 C...No angular correlations in other Higgs decays.
17687 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17688 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17690 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17692 IF(MOD(KFAGM,2).EQ.0) THEN
17700 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17701 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17702 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17703 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17705 ELSEIF(ISUB.EQ.1) THEN
17706 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17707 EI=KCHG(IABS(MINT(15)),1)/3D0
17708 AI=SIGN(1D0,EI+0.1D0)
17710 EF=KCHG(IABS(KFL1(1)),1)/3D0
17711 AF=SIGN(1D0,EF+0.1D0)
17714 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17715 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17716 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17717 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17718 & (VI**2+AI**2)*VINT(114)*VF**2)
17719 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17720 & 4D0*VI*AI*VINT(114)*VF*AF)
17721 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17722 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17723 WTMAX=2D0*(WT1+ABS(WT3))
17725 ELSEIF(ISUB.EQ.2) THEN
17726 C...Angular weight for W+/- -> 2 quarks/leptons.
17727 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17728 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17729 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17730 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17733 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17734 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17735 C...-> gluon/gamma + 2 quarks/leptons.
17736 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17737 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17738 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17739 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17740 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17741 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17742 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17743 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17744 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17745 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17746 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17747 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17748 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17749 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17750 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17751 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17753 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17754 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17755 C...-> gluon/gamma + 2 quarks/leptons.
17756 WT=PKK(1,3)**2+PKK(2,4)**2
17757 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17759 ELSEIF(ISUB.EQ.22) THEN
17760 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17761 S34=P(IREF(IP,IORD),5)**2
17762 S56=P(IREF(IP,3-IORD),5)**2
17763 TI=PKK(1,3)+PKK(1,4)+S34
17764 UI=PKK(1,5)+PKK(1,6)+S56
17767 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17768 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17769 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17770 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17771 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17772 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17773 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17774 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17777 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17778 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17779 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17780 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17781 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17782 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17783 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17786 ELSEIF(ISUB.EQ.23) THEN
17787 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17788 D34=P(IREF(IP,IORD),5)**2
17789 D56=P(IREF(IP,3-IORD),5)**2
17790 DT=PKK(1,3)+PKK(1,4)+D34
17791 DU=PKK(1,5)+PKK(1,6)+D56
17792 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17793 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17794 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17795 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17797 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17798 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17799 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17800 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17801 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17802 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17804 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17805 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17806 C...(or H0, or A0).
17807 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17808 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17809 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17810 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17811 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17813 ELSEIF(ISUB.EQ.25) THEN
17814 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17815 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17816 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17817 D34=P(IREF(IP,IORD),5)**2
17818 D56=P(IREF(IP,3-IORD),5)**2
17819 DT=PKK(1,3)+PKK(1,4)+D34
17820 DU=PKK(1,5)+PKK(1,6)+D56
17821 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17822 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17823 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17824 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17825 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17826 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17827 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17828 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17829 IF(MSTP(50).LE.0) THEN
17830 WT=FGK135**2+(CCWW*FGK253)**2
17831 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17832 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17835 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17836 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17837 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17838 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17841 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17842 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17843 C...(or H0, or A0).
17844 WT=PKK(1,3)*PKK(2,4)
17845 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17847 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17848 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17849 C...-> f + 2 quarks/leptons.
17850 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17851 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17852 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17853 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17854 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17855 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17856 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17857 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17858 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17859 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17860 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17861 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17862 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17863 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17864 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17865 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17866 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17867 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17869 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17870 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17871 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17872 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17873 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17875 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17877 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17878 WT=16D0*PKK(3,5)*PKK(4,6)
17881 ELSEIF(ISUB.EQ.110) THEN
17882 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17886 ELSEIF(ISUB.EQ.141) THEN
17887 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17888 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17889 C...Couplings of incoming flavour.
17890 KFAI=IABS(MINT(15))
17891 EI=KCHG(KFAI,1)/3D0
17892 AI=SIGN(1D0,EI+0.1D0)
17895 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17896 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17897 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17898 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17899 VPI=PARU(119+2*KFAIC)
17900 API=PARU(120+2*KFAIC)
17901 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17902 VPI=PARJ(178+2*KFAIC)
17903 API=PARJ(179+2*KFAIC)
17905 VPI=PARJ(186+2*KFAIC)
17906 API=PARJ(187+2*KFAIC)
17908 C...Couplings of final flavour.
17910 EF=KCHG(KFAF,1)/3D0
17911 AF=SIGN(1D0,EF+0.1D0)
17914 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17915 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17916 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17917 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17918 VPF=PARU(119+2*KFAFC)
17919 APF=PARU(120+2*KFAFC)
17920 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17921 VPF=PARJ(178+2*KFAFC)
17922 APF=PARJ(179+2*KFAFC)
17924 VPF=PARJ(186+2*KFAFC)
17925 APF=PARJ(187+2*KFAFC)
17927 C...Asymmetry and weight.
17928 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17929 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17930 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17931 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17932 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17933 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17934 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17935 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17936 WTMAX=2D0+ABS(ASYM)
17937 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17938 C...Angular weight for f + fbar -> Z' -> W+ + W-.
17939 RM1=P(NSD(1)+1,5)**2/SH
17940 RM2=P(NSD(1)+2,5)**2/SH
17941 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17942 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17943 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17945 WT=CFLAT+CCOS2*CTHE(1)**2
17946 WTMAX=CFLAT+MAX(0D0,CCOS2)
17947 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17948 & IABS(KFL1(1)).EQ.37)) THEN
17949 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17952 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17953 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17954 RM1=P(NSD(1)+1,5)**2/SH
17955 RM2=P(NSD(1)+2,5)**2/SH
17956 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17957 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17958 WTMAX=1D0+FLAM2/(8D0*RM1)
17959 ELSEIF(MZPWP.EQ.0) THEN
17960 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17961 C...(W:s like if intermediate Z).
17962 D34=P(IREF(IP,IORD),5)**2
17963 D56=P(IREF(IP,3-IORD),5)**2
17964 DT=PKK(1,3)+PKK(1,4)+D34
17965 DU=PKK(1,5)+PKK(1,6)+D56
17966 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17967 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17968 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17969 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17970 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17971 ELSEIF(MZPWP.EQ.1) THEN
17972 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17973 C...(W:s approximately longitudinal, like if intermediate H).
17974 WT=16D0*PKK(3,5)*PKK(4,6)
17977 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17978 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17983 ELSEIF(ISUB.EQ.142) THEN
17984 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17985 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17986 KFAI=IABS(MINT(15))
17988 IF(KFAI.GT.10) KFAIC=2
17989 VI=PARU(129+2*KFAIC)
17990 AI=PARU(130+2*KFAIC)
17993 IF(KFAF.GT.10) KFAFC=2
17994 VF=PARU(129+2*KFAFC)
17995 AF=PARU(130+2*KFAFC)
17996 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
17997 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17998 WTMAX=2D0+ABS(ASYM)
17999 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18000 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18001 RM1=P(NSD(1)+1,5)**2/SH
18002 RM2=P(NSD(1)+2,5)**2/SH
18003 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18004 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18005 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18007 WT=CFLAT+CCOS2*CTHE(1)**2
18008 WTMAX=CFLAT+MAX(0D0,CCOS2)
18009 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18010 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18011 RM1=P(NSD(1)+1,5)**2/SH
18012 RM2=P(NSD(1)+2,5)**2/SH
18013 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18014 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18015 WTMAX=1D0+FLAM2/(8D0*RM1)
18016 ELSEIF(MZPWP.EQ.0) THEN
18017 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18018 C...(W/Z like if intermediate W).
18019 D34=P(IREF(IP,IORD),5)**2
18020 D56=P(IREF(IP,3-IORD),5)**2
18021 DT=PKK(1,3)+PKK(1,4)+D34
18022 DU=PKK(1,5)+PKK(1,6)+D56
18023 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18024 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18025 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18026 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18027 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18028 ELSEIF(MZPWP.EQ.1) THEN
18029 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18030 C...(W/Z approximately longitudinal, like if intermediate H).
18031 WT=16D0*PKK(3,5)*PKK(4,6)
18034 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18035 C...t + bbar -> t + W + bbar.
18040 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18042 C...Isotropic decay of leptoquarks (assumed spin 0).
18046 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18047 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18049 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18050 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18051 WT=1D0+SIDE*CTHE(1)
18053 ELSEIF(IP.EQ.1) THEN
18055 RM1=P(NSD(1)+1,5)**2/SH
18056 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18057 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18059 C...W/Z decay assumed isotropic, since not known.
18064 ELSEIF(ISUB.EQ.149) THEN
18065 C...Isotropic decay of techni-eta.
18069 ELSEIF(ISUB.EQ.191) THEN
18070 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18071 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18072 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18075 ELSEIF(IP.EQ.1) THEN
18076 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18077 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18078 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18079 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18080 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18081 KFAI=IABS(MINT(15))
18082 EI=KCHG(KFAI,1)/3D0
18083 AI=SIGN(1D0,EI+0.1D0)
18087 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18088 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18090 EF=KCHG(KFAF,1)/3D0
18091 AF=SIGN(1D0,EF+0.1D0)
18095 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18096 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18097 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18098 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18099 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18100 WTMAX=4D0*MAX(ASAME,AFLIP)
18102 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18107 ELSEIF(ISUB.EQ.192) THEN
18108 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18109 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18110 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18113 ELSEIF(IP.EQ.1) THEN
18114 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18115 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18119 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18124 ELSEIF(ISUB.EQ.193) THEN
18125 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18126 C...Angular weight for f + fbar -> omega_tc0 ->
18127 C...gamma pi_tc0 or Z0 pi_tc0.
18130 ELSEIF(IP.EQ.1) THEN
18131 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18132 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18133 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18134 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18135 KFAI=IABS(MINT(15))
18136 EI=KCHG(KFAI,1)/3D0
18137 AI=SIGN(1D0,EI+0.1D0)
18141 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18142 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18144 EF=KCHG(KFAF,1)/3D0
18145 AF=SIGN(1D0,EF+0.1D0)
18149 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18150 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18151 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18152 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18153 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18154 WTMAX=4D0*MAX(BSAME,BFLIP)
18156 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18161 ELSEIF(ISUB.EQ.353) THEN
18162 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18163 EI=KCHG(IABS(MINT(15)),1)/3D0
18164 AI=SIGN(1D0,EI+0.1D0)
18166 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18167 AF=SIGN(1D0,EF+0.1D0)
18169 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18170 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18171 WT2=RMF*(VI**2+AI**2)*VF**2
18172 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18173 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18174 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18175 WTMAX=2D0*(WT1+ABS(WT3))
18177 ELSEIF(ISUB.EQ.354) THEN
18178 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18179 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18180 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18181 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18182 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18185 ELSEIF(ISUB.EQ.391) THEN
18186 C...Angular weight for f + fbar -> G* -> f + fbar
18187 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18188 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18190 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18191 C...implemented by M.-C. Lemaire
18192 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18193 & IABS(KFL1(1)).EQ.22)) THEN
18196 C...Other G* decays not yet implemented angular distributions.
18202 ELSEIF(ISUB.EQ.392) THEN
18203 C...Angular weight for g + g -> G* -> f + fbar
18204 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18207 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18208 C...implemented by M.-C. Lemaire
18209 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18210 & IABS(KFL1(1)).EQ.22)) THEN
18211 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18213 C...Other G* decays not yet implemented angular distributions.
18219 C...Obtain correct angular distribution by rejection techniques.
18224 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18226 C...Construct massive four-vectors using angles chosen.
18227 590 DO 690 JT=1,JTMAX
18228 IF(KDCY(JT).EQ.0) GOTO 690
18233 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18235 IF(KFL3(JT).EQ.0) THEN
18236 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18237 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18240 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18241 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18246 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18248 C...Fill in position of decay vertex.
18249 DO 630 I=NSD(JT)+1,N0
18258 C...Mark decayed resonances; trace history.
18262 IF(KCQM(JT).NE.0) THEN
18263 C...Do not kill colour flow through coloured resonance!
18267 C...If 3-body or 2-body with junction:
18268 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18269 C...If 3-body with junction:
18270 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18273 C...Add documentation lines.
18274 ISUBRG=MAX(1,MIN(500,MINT(1)))
18275 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18276 IDOC=MINT(83)+MINT(4)
18279 IF(KFL3(JT).NE.0) IHI=IHI+1
18280 DO 650 I=NSD(JT)+1,IHI
18282 I1=MINT(83)+MINT(4)+1
18284 IF(MSTP(128).GE.1) K(I,3)=ID
18285 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18289 K(I1,3)=IREF(IP,JT+3)
18298 C...If 3-body or 2-body with junction:
18299 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18300 C...If 3-body with junction:
18301 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18304 C...Do showering of two or three objects.
18306 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18307 IF(KFL3(JT).EQ.0) THEN
18308 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18310 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18313 c...For pT-ordered shower need set up first, especially colour tags.
18314 C...(Need to set up colour tags even if MSTP(71) = 0)
18315 ELSEIF(MINT(35).GE.2) THEN
18317 IF(KFL3(JT).NE.0) NPART=3
18321 PTPART(1)=0.5D0*P(ID,5)
18322 PTPART(2)=PTPART(1)
18323 PTPART(3)=PTPART(1)
18324 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18325 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18326 IF(MOTHER.LE.NSD(JT)) THEN
18327 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18330 MCT(NSD(JT)+1,1)=NCT
18334 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18335 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18336 IF(MOTHER.LE.NSD(JT)) THEN
18337 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18340 MCT(NSD(JT)+1,2)=NCT
18344 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18345 & KCQ2(JT).EQ.2)) THEN
18346 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18347 IF(MOTHER.LE.NSD(JT)) THEN
18348 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18351 MCT(NSD(JT)+2,1)=NCT
18355 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18356 & KCQ2(JT).EQ.2)) THEN
18357 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18358 IF(MOTHER.LE.NSD(JT)) THEN
18359 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18362 MCT(NSD(JT)+2,2)=NCT
18366 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18367 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18368 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18369 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18371 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18372 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18373 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18374 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18376 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18379 IF(JT.EQ.1) NAFT1=N
18381 C...Check if decay products moved by shower.
18385 IF(NSHAFT.GT.NSHBEF) THEN
18386 IF(K(NSD1,1).GT.10) THEN
18387 DO 660 I=NSHBEF+1,NSHAFT
18388 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
18391 IF(K(NSD2,1).GT.10) THEN
18392 DO 670 I=NSHBEF+1,NSHAFT
18393 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
18394 & I.NE.NSD1) NSD2=I
18397 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
18398 DO 680 I=NSHBEF+1,NSHAFT
18399 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
18400 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
18405 C...Store decay products for further treatment.
18410 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
18414 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
18415 IREF(NP,7)=K(IREF(IP,JT),2)
18416 IREF(NP,8)=IREF(IP,JT)
18420 C...Fill information for 2 -> 1 -> 2.
18421 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
18422 MINT(7)=MINT(83)+6+2*ISET(ISUB)
18423 MINT(8)=MINT(83)+7+2*ISET(ISUB)
18429 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18430 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
18431 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
18432 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
18433 VINT(47)=SQRT(VINT(48))
18436 C...Possibility of colour rearrangement in W+W- events.
18437 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
18438 IAKF1=IABS(KFL1(1))
18439 IAKF2=IABS(KFL1(2))
18440 IAKF3=IABS(KFL2(1))
18441 IAKF4=IABS(KFL2(2))
18442 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
18443 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
18444 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
18445 IF(MINT(51).NE.0) RETURN
18448 C...Loop back if needed.
18449 710 IF(IP.LT.NP) GOTO 170
18451 C...Boost back to standard frame.
18452 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
18458 C*********************************************************************
18461 C...Initializes treatment of multiple interactions, selects kinematics
18462 C...of hardest interaction if low-pT physics included in run, and
18463 C...generates all non-hardest interactions.
18465 SUBROUTINE PYMULT(MMUL)
18467 C...Double precision and integer declarations.
18468 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18469 IMPLICIT INTEGER(I-N)
18470 INTEGER PYK,PYCHGE,PYCOMP
18472 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18475 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18476 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18477 COMMON/PYINT1/MINT(400),VINT(400)
18478 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18479 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18480 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18481 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18482 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
18483 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
18484 C...Local arrays and saved variables.
18485 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
18486 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
18487 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
18488 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
18490 C...Initialization of multiple interaction treatment.
18492 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
18500 C...Loop over phase space points: xT2 choice in 20 bins.
18503 NMUL(IXT2)=MSTP(83)
18505 DO 110 ITRY=1,MSTP(83)
18506 RSCA=0.05D0*((21-IXT2)-PYR(0))
18507 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
18508 XT2=MAX(0.01D0*VINT(149),XT2)
18511 C...Choose tau and y*. Calculate cos(theta-hat).
18512 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18513 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18514 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18516 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18522 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18523 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18524 CALL PYKMAP(2,MYST,PYR(0))
18525 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18527 C...Calculate differential cross-section.
18528 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18529 CALL PYSIGH(NCHN,SIGS)
18530 SIGM(IXT2)=SIGM(IXT2)+SIGS
18532 SIGSUM=SIGSUM+SIGM(IXT2)
18534 SIGSUM=SIGSUM/(20D0*MSTP(83))
18536 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
18537 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
18538 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
18539 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
18540 PARP(82)=0.9D0*PARP(82)
18541 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
18545 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
18546 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
18548 C...Start iteration to find k factor.
18549 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
18550 P83A=(1D0-PARP(83))**2
18551 P83B=2D0*PARP(83)*(1D0-PARP(83))
18553 CQ2I=1D0/PARP(84)**2
18554 CQ2R=2D0/(1D0+PARP(84)**2)
18562 130 IF(IIT.EQ.0) THEN
18564 ELSEIF(IIT.EQ.1) THEN
18567 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
18570 C...Evaluate overlap integrals. Find where to divide the b range.
18571 IF(MSTP(82).EQ.2) THEN
18572 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
18575 IF(MSTP(82).EQ.3) THEN
18577 ELSEIF(MSTP(82).EQ.4) THEN
18578 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
18580 POWIP=MAX(0.4D0,PARP(83))
18581 RPWIP=2D0/POWIP-1D0
18582 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18592 IF(MSTP(82).EQ.3) THEN
18593 OV=EXP(-B**2)/PARU(2)
18594 ELSEIF(MSTP(82).EQ.4) THEN
18595 OV=(P83A*EXP(-MIN(50D0,B**2))+
18596 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18597 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18599 OV=EXP(-B**POWIP)/PARU(2)
18600 SO=SO+PARU(2)*B*DELTAB*OV
18602 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18603 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18604 SP=SP+PARU(2)*B*DELTAB*PACC
18605 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18606 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18607 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18609 BDIV=B+0.5D0*DELTAB
18611 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18613 YK=PARU(1)*XK*SO/SP
18615 C...Continue iteration until convergence.
18625 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18627 C...Store some results for subsequent use.
18635 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18636 PIK=(VNT146/VNT147)*YKE
18638 C...Find relative weight for low and high impact parameter.
18639 PLOWB=PARU(1)*BDIV**2
18640 IF(MSTP(82).EQ.3) THEN
18641 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18642 ELSEIF(MSTP(82).EQ.4) THEN
18643 S4A=P83A*EXP(-BDIV**2)
18644 S4B=P83B*EXP(-BDIV**2*CQ2R)
18645 S4C=P83C*EXP(-BDIV**2*CQ2I)
18646 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18647 ELSEIF(PARP(83).GE.1.999D0) THEN
18653 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18657 C...Initialize iteration in xT2 for hardest interaction.
18658 ELSEIF(MMUL.EQ.2) THEN
18662 IF(MSTP(82).LE.0) THEN
18663 ELSEIF(MSTP(82).EQ.1) THEN
18665 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18666 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18667 & VINT(317)/(VINT(318)*VINT(320))
18668 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18669 ELSEIF(MSTP(82).EQ.2) THEN
18671 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18672 & VINT(149)*(1D0+VINT(149))
18674 XC2=4D0*CKIN(3)**2/VINT(2)
18675 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18678 C...Select impact parameter for hardest interaction.
18679 IF(MSTP(82).LE.2) RETURN
18680 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18681 C...Treatment in low b region.
18683 B=BDIV*SQRT(PYR(0))
18684 IF(MSTP(82).EQ.3) THEN
18685 OV=EXP(-B**2)/PARU(2)
18686 ELSEIF(MSTP(82).EQ.4) THEN
18687 OV=(P83A*EXP(-MIN(50D0,B**2))+
18688 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18689 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18691 OV=EXP(-B**POWIP)/PARU(2)
18693 VINT(148)=OV/VNT147
18694 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18696 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18697 & VINT(149)*(1D0+VINT(149))
18699 C...Treatment in high b region.
18701 IF(MSTP(82).EQ.3) THEN
18702 B=SQRT(BDIV**2-LOG(PYR(0)))
18703 OV=EXP(-B**2)/PARU(2)
18704 ELSEIF(MSTP(82).EQ.4) THEN
18705 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18706 IF(S4RNDM.LT.S4A) THEN
18707 B=SQRT(BDIV**2-LOG(PYR(0)))
18708 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18709 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18711 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18713 OV=(P83A*EXP(-MIN(50D0,B**2))+
18714 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18715 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18716 ELSEIF(PARP(83).GE.1.999D0) THEN
18717 144 B2RPW=B2RPDV-LOG(PYR(0))
18718 ACCIP=(B2RPW/B2RPDV)**RPWIP
18719 IF(ACCIP.LT.PYR(0)) GOTO 144
18720 OV=EXP(-B2RPW)/PARU(2)
18721 B=B2RPW**(1D0/POWIP)
18723 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18724 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18725 IF(ACCIP.LT.PYR(0)) GOTO 146
18726 OV=EXP(-B2RPW)/PARU(2)
18727 B=B2RPW**(1D0/POWIP)
18729 VINT(148)=OV/VNT147
18730 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18732 IF(PACC.LT.PYR(0)) GOTO 142
18735 ELSEIF(MMUL.EQ.3) THEN
18736 C...Low-pT or multiple interactions (first semihard interaction):
18737 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18738 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18743 IF(MSTP(82).LE.0) THEN
18745 ELSEIF(MSTP(82).EQ.1) THEN
18746 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18747 C...Use with "Sudakov" for low b values when impact parameter dependence.
18748 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18749 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18750 & VINT(149)))).GT.PYR(0)) XT2=1D0
18751 IF(XT2.GE.1D0) THEN
18752 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18753 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18756 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18757 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18760 XT2=MAX(0.01D0*VINT(149),XT2)
18761 C...Use without "Sudakov" for high b values when impact parameter dep.
18763 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18764 & PYR(0)*(1D0-XC2))-VINT(149)
18765 XT2=MAX(0.01D0*VINT(149),XT2)
18769 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18770 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18771 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18772 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18775 VINT(21)=0.01D0*VINT(149)
18778 VINT(25)=0.01D0*VINT(149)
18781 C...Multiple interactions (first semihard interaction).
18782 C...Choose tau and y*. Calculate cos(theta-hat).
18783 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18784 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18785 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18787 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18793 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18794 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18795 CALL PYKMAP(2,MYST,PYR(0))
18796 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18798 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18800 C...Store results of cross-section calculation.
18801 ELSEIF(MMUL.EQ.4) THEN
18807 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18808 IF(ISET(ISUB).EQ.2)
18809 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18810 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18811 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18812 & (XTS+VINT(149))))
18813 IRBIN=INT(1D0+20D0*RBIN)
18814 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18815 NMUL(IRBIN)=NMUL(IRBIN)+1
18816 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18819 C...Choose impact parameter if not already done.
18820 ELSEIF(MMUL.EQ.5) THEN
18825 150 IF(MINT(39).GT.0) THEN
18826 ELSEIF(MSTP(82).EQ.3) THEN
18829 VINT(148)=EXPB2/(PARU(2)*VNT147)
18830 VINT(139)=SQRT(B2)/BAVG
18831 ELSEIF(MSTP(82).EQ.4) THEN
18833 IF(RTYPE.LT.P83A) THEN
18835 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18836 B2=-LOG(PYR(0))/CQ2R
18838 B2=-LOG(PYR(0))/CQ2I
18840 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18841 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18842 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18843 VINT(139)=SQRT(B2)/BAVG
18844 ELSEIF(PARP(83).GE.1.999D0) THEN
18845 POWIP=MAX(2D0,PARP(83))
18846 RPWIP=2D0/POWIP-1D0
18847 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18848 160 IF(PYR(0).LT.PROB1) THEN
18849 B2RPW=PYR(0)**(0.5D0*POWIP)
18852 B2RPW=1D0-LOG(PYR(0))
18855 IF(ACCIP.LT.PYR(0)) GOTO 160
18856 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18857 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18859 POWIP=MAX(0.4D0,PARP(83))
18860 RPWIP=2D0/POWIP-1D0
18861 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18862 170 IF(PYR(0).LT.PROB1) THEN
18863 B2RPW=2D0*RPWIP*PYR(0)
18864 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18866 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18867 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18869 IF(ACCIP.LT .PYR(0)) GOTO 170
18870 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18871 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18874 C...Multiple interactions (variable impact parameter) : reject with
18875 C...probability exp(-overlap*cross-section above pT/normalization).
18876 C...Does not apply to low-b region, where "Sudakov" already included.
18878 IF(MINT(39).NE.1) THEN
18879 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18880 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18881 DO 180 IBIN=IRBIN+1,20
18882 RNCOR=RNCOR+NMUL(IBIN)
18883 SIGCOR=SIGCOR+SIGM(IBIN)
18885 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18886 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18887 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18888 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18890 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18891 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18892 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18893 IF(VINT(150).LT.PYR(0)) GOTO 150
18897 C...Generate additional multiple semihard interactions.
18898 ELSEIF(MMUL.EQ.6) THEN
18911 C...Reconstruct strings in hard scattering.
18913 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18914 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18916 DO 210 I=MINT(84)+1,NMAX
18917 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18918 IF(KCS.EQ.0) GOTO 210
18920 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18921 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18923 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18925 IST=MOD(K(I,J+1),MSTU(5))
18927 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18928 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18930 IF(J.EQ.1.OR.J.EQ.4) THEN
18940 C...Set up starting values for iteration in xT2.
18941 XT2=4D0*VINT(62)/VINT(2)
18942 IF(MSTP(82).LE.1) THEN
18943 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18944 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18945 & VINT(317)/(VINT(318)*VINT(320))
18946 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18948 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18949 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18953 VINT(143)=1D0-VINT(141)
18954 VINT(144)=1D0-VINT(142)
18956 C...Iterate downwards in xT2.
18957 220 IF(MSTP(82).LE.1) THEN
18958 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18959 IF(XT2.LT.VINT(149)) GOTO 270
18961 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18962 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18963 & LOG(PYR(0)))-VINT(149)
18964 IF(XT2.LE.0D0) GOTO 270
18965 XT2=MAX(0.01D0*VINT(149),XT2)
18969 C...Choose tau and y*. Calculate cos(theta-hat).
18970 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18971 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18972 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18974 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18980 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18981 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18982 CALL PYKMAP(2,MYST,PYR(0))
18983 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18985 C...Check that x not used up. Accept or reject kinematical variables.
18986 X1M=SQRT(TAU)*EXP(VINT(22))
18987 X2M=SQRT(TAU)*EXP(-VINT(22))
18988 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
18989 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18990 CALL PYSIGH(NCHN,SIGS)
18991 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
18992 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
18994 C...Reset K, P and V vectors. Select some variables.
19003 PT=0.5D0*VINT(1)*SQRT(XT2)
19007 C...Add first parton to event record.
19010 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19011 & 1+INT((2D0+PARJ(2))*PYR(0))
19012 P(N+1,1)=PT*COS(PHI)
19013 P(N+1,2)=PT*SIN(PHI)
19014 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19015 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19018 C...Add second parton to event record.
19021 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19024 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19025 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19028 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19029 C....Choose relevant string pieces to place gluons on.
19035 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19036 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19037 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19038 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19039 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19047 C....Colour flow adjustments, new string pieces.
19048 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19049 & MOD(K(IST1,4),MSTU(5))
19050 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19051 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19052 K(I,5)=MSTU(5)*IST1
19053 K(I,4)=MSTU(5)*IST2
19054 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19055 & MOD(K(IST2,5),MSTU(5))
19056 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19057 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19060 KSTR(NSTR+1,2)=IST2
19064 C...String drawing and colour flow for gluon loop.
19065 ELSEIF(K(N+1,2).EQ.21) THEN
19066 K(N+1,4)=MSTU(5)*(N+2)
19067 K(N+1,5)=MSTU(5)*(N+2)
19068 K(N+2,4)=MSTU(5)*(N+1)
19069 K(N+2,5)=MSTU(5)*(N+1)
19076 C...String drawing and colour flow for qqbar pair.
19078 K(N+1,4)=MSTU(5)*(N+2)
19079 K(N+2,5)=MSTU(5)*(N+1)
19085 C...Global statistics.
19086 MINT(351)=MINT(351)+1
19087 VINT(351)=VINT(351)+PT
19088 IF (MINT(351).EQ.1) VINT(356)=PT
19090 C...Update remaining energy; iterate.
19092 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19093 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19097 MINT(31)=MINT(31)+1
19098 VINT(151)=VINT(151)+VINT(41)
19099 VINT(152)=VINT(152)+VINT(42)
19100 VINT(143)=VINT(143)-VINT(41)
19101 VINT(144)=VINT(144)-VINT(42)
19102 C...Allow FSR for UE
19103 IF(MSTP(152).EQ.1) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19104 IF(MINT(31).LT.240) GOTO 220
19112 C...Format statements for printout.
19113 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19114 &'actions for MSTP(82) =',I2,' ******')
19115 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19116 &D9.2,' mb: rejected')
19117 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19118 &D9.2,' mb: accepted')
19123 C*********************************************************************
19126 C...Adds on target remnants (one or two from each side) and
19127 C...includes primordial kT for hadron beams.
19129 SUBROUTINE PYREMN(IPU1,IPU2)
19131 C...Double precision and integer declarations.
19132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19133 IMPLICIT INTEGER(I-N)
19134 INTEGER PYK,PYCHGE,PYCOMP
19136 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19138 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19139 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19140 COMMON/PYINT1/MINT(400),VINT(400)
19141 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19143 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19144 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19146 C...Find event type and remaining energy.
19149 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19150 VINT(143)=1D0-VINT(141)
19151 VINT(144)=1D0-VINT(142)
19154 C...Define initial partons.
19159 IF(JT.EQ.1) IPU=IPU1
19160 IF(JT.EQ.2) IPU=IPU2
19167 IF(MINT(47).EQ.1) THEN
19171 ELSEIF(ISUB.EQ.95) THEN
19176 C...No primordial kT, or chosen according to truncated Gaussian or
19177 C...exponential, or (for photon) predetermined or power law.
19178 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19179 IF(MSTP(91).LE.0) THEN
19181 ELSEIF(MSTP(91).EQ.1) THEN
19182 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19186 PT=-PARP(92)*LOG(RPT1*RPT2)
19188 IF(PT.GT.PARP(93)) GOTO 120
19189 ELSEIF(MINT(106+JT).EQ.3) THEN
19190 PTA=SQRT(VINT(282+JT))
19192 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19193 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19194 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19197 PTB=-PARP(99)*LOG(RPT1*RPT2)
19199 IF(PTB.GT.PARP(100)) GOTO 120
19200 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19201 PT=PT*0.8D0**MINT(57)
19202 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19203 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19204 IF(MSTP(93).LE.0) THEN
19206 ELSEIF(MSTP(93).EQ.1) THEN
19207 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19208 ELSEIF(MSTP(93).EQ.2) THEN
19211 PT=-PARP(99)*LOG(RPT1*RPT2)
19212 ELSEIF(MSTP(93).EQ.3) THEN
19215 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19219 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19220 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19222 IF(PT.GT.PARP(100)) GOTO 120
19230 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19233 IF(MINT(47).EQ.1) RETURN
19235 C...Kinematics construction for initial partons.
19238 IF(ISUB.EQ.95) THEN
19242 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19243 & (P(I1,2)+P(I2,2))**2
19244 SHR=SQRT(MAX(0D0,SHS))
19245 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19246 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19247 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19248 P(I2,4)=SHR-P(I1,4)
19251 C...Transform partons to overall CM-frame.
19252 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19253 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19254 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19255 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19256 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19257 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19258 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19259 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19260 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19261 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19262 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19265 C...Optionally fix up x and Q2 definitions for leptoproduction.
19267 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19268 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19269 IF(IDISXQ.EQ.1) THEN
19271 C...Find where incoming and outgoing leptons/partons are sitting.
19273 IF(MINT(42).EQ.1) LESD=2
19274 LPIN=MINT(83)+3-LESD
19276 LQIN=MINT(84)+3-LESD
19277 LEOUT=MINT(84)+2+LESD
19278 LQOUT=MINT(84)+5-LESD
19279 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19280 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19282 DO 140 I=MINT(84)+5,N
19283 IF(K(I,2).EQ.94) THEN
19290 IF(LESD.EQ.1) LQBG=IPU2
19292 C...Calculate actual and wanted momentum transfer.
19295 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19296 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19297 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19298 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19299 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19300 P(N+1,1)=FAC*P(LEOUT,1)
19301 P(N+1,2)=FAC*P(LEOUT,2)
19302 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19303 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19304 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19307 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19308 QNEW(J)=P(LEIN,J)-P(N+1,J)
19311 C...Boost outgoing electron and daughters.
19312 IF(LSCMS.EQ.0) THEN
19314 P(LEOUT,J)=P(N+1,J)
19318 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19320 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19322 DBE(J)=PINV*P(N+2,J)
19326 190 IORIG=K(IORIG,3)
19327 IF(IORIG.GT.LEOUT) GOTO 190
19328 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19329 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19333 C...Copy shower initiator and all outgoing partons.
19337 P(NCOP,J)=P(LQBG,J)
19339 DO 240 I=MINT(84)+1,N
19341 IF(K(I,1).GT.10) GOTO 240
19342 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19346 220 IORIG=K(IORIG,3)
19347 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19349 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19362 C...Calculate relative rescaling factors.
19366 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19369 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
19372 C...Transfer extra three-momentum of current.
19375 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
19377 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19380 C...Iterate change of initiator momentum to get energy right.
19383 PEEX=-P(N+1,4)-QNEW(4)
19384 PEMV=-P(N+1,3)/P(N+1,4)
19387 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
19389 IF(ABS(PEMV).LT.1D-10) THEN
19391 MINT(57)=MINT(57)+1
19395 P(N+1,3)=P(N+1,3)+PZCH
19396 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)
19398 P(I,3)=P(I,3)+V(I,1)*PZCH
19399 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19401 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
19403 C...Modify momenta in event record.
19404 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
19405 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
19406 IF(ABS(HBE).GE.1D0) THEN
19408 MINT(57)=MINT(57)+1
19412 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
19421 C...Check minimum invariant mass of remnant system(s).
19422 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
19423 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
19424 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19425 PMIN(0)=SQRT(PMS(0))
19427 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
19428 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
19430 IF(MINT(44+JT).EQ.1) GOTO 340
19431 MINT(105)=MINT(102+JT)
19432 MINT(109)=MINT(106+JT)
19433 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
19434 IF(MINT(51).NE.0) THEN
19435 MINT(57)=MINT(57)+1
19438 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
19439 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
19440 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
19441 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
19442 & P(MINT(83)+JT+2,2)**2)
19444 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
19445 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
19448 MINT(57)=MINT(57)+1
19452 C...Loop over two remnants; skip if none there.
19456 IF(MINT(44+JT).EQ.1) GOTO 410
19457 IF(JT.EQ.1) IPU=IPU1
19458 IF(JT.EQ.2) IPU=IPU2
19460 C...Store first remnant parton.
19472 P(I,5)=PYMASS(K(I,2))
19474 C...First parton colour connections and kinematics.
19475 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
19478 K(I,4)=MSTU(5)*IPU+IPU
19479 K(I,5)=MSTU(5)*IPU+IPU
19480 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19481 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19482 ELSEIF(KCOL.NE.0) THEN
19484 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
19486 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19488 IF(KFLCH(JT).EQ.0) THEN
19489 P(I,1)=-P(MINT(83)+JT+2,1)
19490 P(I,2)=-P(MINT(83)+JT+2,2)
19491 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19492 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19496 C...When extra remnant parton or hadron: store extra remnant.
19508 P(I,5)=PYMASS(K(I,2))
19510 C...Find parton colour connections of extra remnant.
19511 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
19514 K(I,4)=MSTU(5)*IPU+IPU
19515 K(I,5)=MSTU(5)*IPU+IPU
19516 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19517 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19518 ELSEIF(KCOL.NE.0) THEN
19520 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
19522 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19525 C...Relative transverse momentum when two remnants.
19528 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
19529 IF(IABS(MINT(10+JT)).LT.20) THEN
19533 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
19534 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
19536 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
19537 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
19538 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
19539 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19541 C...Meson or baryon; photon as meson. For splitup below.
19543 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
19545 C***Relative distribution for electron into two electrons. Temporary!
19546 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
19550 C...Relative distribution of electron energy into electron plus parton.
19551 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
19554 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
19556 C...Relative distribution of energy for particle into two jets.
19557 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
19558 CHIK=PARP(92+2*IMB)
19559 IF(MSTP(92).LE.1) THEN
19560 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19561 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19562 ELSEIF(MSTP(92).EQ.2) THEN
19563 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
19564 ELSEIF(MSTP(92).EQ.3) THEN
19565 CUT=2D0*0.3D0/VINT(1)
19566 380 CHI(JT)=PYR(0)**2
19567 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
19568 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
19569 ELSEIF(MSTP(92).EQ.4) THEN
19570 CUT=2D0*0.3D0/VINT(1)
19571 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
19572 390 CHIR=CUT*CUTR**PYR(0)
19573 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
19574 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
19576 CUT=2D0*0.3D0/VINT(1)
19577 CUTA=CUT**(1D0-PARP(98))
19578 CUTB=(1D0+CUT)**(1D0-PARP(98))
19579 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
19580 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
19581 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
19584 C...Relative distribution of energy for particle into jet plus particle.
19586 IF(MSTP(94).LE.1) THEN
19587 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19588 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19589 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19590 ELSEIF(MSTP(94).EQ.2) THEN
19591 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
19592 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19593 ELSEIF(MSTP(94).EQ.3) THEN
19594 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19597 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19602 C...Construct total transverse mass; reject if too large.
19603 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19604 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19605 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19606 IF(LOOP.LT.100) THEN
19610 MINT(57)=MINT(57)+1
19614 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19615 VINT(158+JT)=CHI(JT)
19617 C...Subdivide longitudinal momentum according to value selected above.
19618 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19619 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19620 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19621 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19622 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19627 C...Check if longitudinal boosts needed - if so pick two systems.
19628 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19629 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19630 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19631 IF(ISN(1).EQ.0) THEN
19634 ELSEIF(ISN(2).EQ.0) THEN
19637 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19640 ELSEIF(VINT(143).GT.0.2D0) THEN
19643 ELSEIF(VINT(144).GT.0.2D0) THEN
19646 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19655 C...E+-pL wanted for system to be modified.
19656 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19660 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19661 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19664 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19665 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19666 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19667 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19671 DO 450 I=MINT(84)+1,NS
19672 IF(K(I,1).GT.10) GOTO 450
19675 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19677 IF(IORIG.GT.LPIN) GOTO 430
19678 IF(INCL.EQ.0) GOTO 450
19680 PSYS(0,J)=PSYS(0,J)+P(I,J)
19683 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19684 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19685 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19688 C...Construct longitudinal boosts.
19692 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19693 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19695 MINT(57)=MINT(57)+1
19698 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19699 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19700 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19701 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19702 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19703 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19704 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19706 C...Perform longitudinal boosts.
19707 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19709 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19710 ELSEIF(IR.EQ.1) THEN
19711 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19712 ELSEIF(IDISXQ.EQ.1) THEN
19716 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19718 IF(IORIG.GT.LPIN) GOTO 460
19719 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19722 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19724 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19726 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19727 ELSEIF(IL.EQ.2) THEN
19728 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19729 ELSEIF(IDISXQ.EQ.1) THEN
19733 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19735 IF(IORIG.GT.LPIN) GOTO 480
19736 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19739 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19742 C...Final check that energy-momentum conservation worked.
19745 DO 500 I=MINT(84)+1,N
19746 IF(K(I,1).GT.10) GOTO 500
19750 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19751 IF(PDEV.GT.1D-4*VINT(1)) THEN
19753 MINT(57)=MINT(57)+1
19757 C...Calculate rotation and boost from overall CM frame to
19758 C...hadronic CM frame in leptoproduction.
19760 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19763 IF(MINT(42).EQ.1) LESD=2
19764 LPIN=MINT(83)+3-LESD
19766 C...Sum upp momenta of everything not lepton or photon to define boost.
19771 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19772 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19773 IF(K(I,2).EQ.22) GOTO 530
19775 PSUM(J)=PSUM(J)+P(I,J)
19778 VINT(223)=-PSUM(1)/PSUM(4)
19779 VINT(224)=-PSUM(2)/PSUM(4)
19780 VINT(225)=-PSUM(3)/PSUM(4)
19782 C...Boost incoming hadron to hadronic CM frame to determine rotations.
19788 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19789 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19790 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19792 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19794 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19801 C*********************************************************************
19804 C...Initializes treatment of new multiple interactions scenario,
19805 C...selects kinematics of hardest interaction if low-pT physics
19806 C...included in run, and generates all non-hardest interactions.
19808 SUBROUTINE PYMIGN(MMUL)
19810 C...Double precision and integer declarations.
19811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19812 IMPLICIT INTEGER(I-N)
19813 INTEGER PYK,PYCHGE,PYCOMP
19815 DOUBLE PRECISION PYALPS
19817 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19820 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19821 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19822 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19823 COMMON/PYINT1/MINT(400),VINT(400)
19824 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19825 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19826 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19827 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19828 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19829 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19830 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19831 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19832 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19833 C...Local arrays and saved variables.
19834 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19835 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19836 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19837 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19838 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19840 C...Initialization of multiple interaction treatment.
19842 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19850 C...Loop over phase space points: xT2 choice in 20 bins.
19853 NMUL(IXT2)=MSTP(83)
19855 DO 110 ITRY=1,MSTP(83)
19856 RSCA=0.05D0*((21-IXT2)-PYR(0))
19857 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19858 XT2=MAX(0.01D0*VINT(149),XT2)
19861 C...Choose tau and y*. Calculate cos(theta-hat).
19862 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19863 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19864 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19866 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19872 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19873 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19874 CALL PYKMAP(2,MYST,PYR(0))
19875 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19877 C...Calculate differential cross-section.
19878 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19879 CALL PYSIGH(NCHN,SIGS)
19880 SIGM(IXT2)=SIGM(IXT2)+SIGS
19882 SIGSUM=SIGSUM+SIGM(IXT2)
19884 SIGSUM=SIGSUM/(20D0*MSTP(83))
19886 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19887 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19888 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19889 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19890 PARP(82)=0.9D0*PARP(82)
19891 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19895 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19896 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19898 C...Start iteration to find k factor.
19899 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19900 P83A=(1D0-PARP(83))**2
19901 P83B=2D0*PARP(83)*(1D0-PARP(83))
19903 CQ2I=1D0/PARP(84)**2
19904 CQ2R=2D0/(1D0+PARP(84)**2)
19912 130 IF(IIT.EQ.0) THEN
19914 ELSEIF(IIT.EQ.1) THEN
19917 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19920 C...Evaluate overlap integrals. Find where to divide the b range.
19921 IF(MSTP(82).EQ.2) THEN
19922 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19925 IF(MSTP(82).EQ.3) THEN
19927 ELSEIF(MSTP(82).EQ.4) THEN
19928 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19930 POWIP=MAX(0.4D0,PARP(83))
19931 RPWIP=2D0/POWIP-1D0
19932 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19942 IF(MSTP(82).EQ.3) THEN
19943 OV=EXP(-B**2)/PARU(2)
19944 ELSEIF(MSTP(82).EQ.4) THEN
19945 OV=(P83A*EXP(-MIN(50D0,B**2))+
19946 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19947 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19949 OV=EXP(-B**POWIP)/PARU(2)
19950 SO=SO+PARU(2)*B*DELTAB*OV
19952 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19953 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19954 SP=SP+PARU(2)*B*DELTAB*PACC
19955 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19956 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19957 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19959 BDIV=B+0.5D0*DELTAB
19961 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19963 YK=PARU(1)*XK*SO/SP
19965 C...Continue iteration until convergence.
19975 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19977 C...Store some results for subsequent use.
19985 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19986 PIK=(VNT146/VNT147)*YKE
19988 C...Find relative weight for low and high impact parameter..
19989 PLOWB=PARU(1)*BDIV**2
19990 IF(MSTP(82).EQ.3) THEN
19991 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19992 ELSEIF(MSTP(82).EQ.4) THEN
19993 S4A=P83A*EXP(-BDIV**2)
19994 S4B=P83B*EXP(-BDIV**2*CQ2R)
19995 S4C=P83C*EXP(-BDIV**2*CQ2I)
19996 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19997 ELSEIF(PARP(83).GE.1.999D0) THEN
20003 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20007 C...Initialize iteration in xT2 for hardest interaction.
20008 ELSEIF(MMUL.EQ.2) THEN
20012 IF(MSTP(82).LE.0) THEN
20013 ELSEIF(MSTP(82).EQ.1) THEN
20015 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20016 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20017 & VINT(317)/(VINT(318)*VINT(320))
20018 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20019 ELSEIF(MSTP(82).EQ.2) THEN
20021 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20022 & VINT(149)*(1D0+VINT(149))
20024 XC2=4D0*CKIN(3)**2/VINT(2)
20025 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20028 C...Select impact parameter for hardest interaction.
20029 IF(MSTP(82).LE.2) RETURN
20030 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20031 C...Treatment in low b region.
20033 B=BDIV*SQRT(PYR(0))
20034 IF(MSTP(82).EQ.3) THEN
20035 OV=EXP(-B**2)/PARU(2)
20036 ELSEIF(MSTP(82).EQ.4) THEN
20037 OV=(P83A*EXP(-MIN(50D0,B**2))+
20038 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20039 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20041 OV=EXP(-B**POWIP)/PARU(2)
20043 VINT(148)=OV/VNT147
20044 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20046 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20047 & VINT(149)*(1D0+VINT(149))
20049 C...Treatment in high b region.
20051 IF(MSTP(82).EQ.3) THEN
20052 B=SQRT(BDIV**2-LOG(PYR(0)))
20053 OV=EXP(-B**2)/PARU(2)
20054 ELSEIF(MSTP(82).EQ.4) THEN
20055 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20056 IF(S4RNDM.LT.S4A) THEN
20057 B=SQRT(BDIV**2-LOG(PYR(0)))
20058 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20059 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20061 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20063 OV=(P83A*EXP(-MIN(50D0,B**2))+
20064 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20065 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20066 ELSEIF(PARP(83).GE.1.999D0) THEN
20067 144 B2RPW=B2RPDV-LOG(PYR(0))
20068 ACCIP=(B2RPW/B2RPDV)**RPWIP
20069 IF(ACCIP.LT.PYR(0)) GOTO 144
20070 OV=EXP(-B2RPW)/PARU(2)
20071 B=B2RPW**(1D0/POWIP)
20073 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20074 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20075 IF(ACCIP.LT.PYR(0)) GOTO 146
20076 OV=EXP(-B2RPW)/PARU(2)
20077 B=B2RPW**(1D0/POWIP)
20079 VINT(148)=OV/VNT147
20080 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20082 IF(PACC.LT.PYR(0)) GOTO 142
20085 ELSEIF(MMUL.EQ.3) THEN
20086 C...Low-pT or multiple interactions (first semihard interaction):
20087 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20088 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20093 IF(MSTP(82).LE.0) THEN
20095 ELSEIF(MSTP(82).EQ.1) THEN
20096 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20097 C...Use with "Sudakov" for low b values when impact parameter dependence.
20098 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20099 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20100 & VINT(149)))).GT.PYR(0)) XT2=1D0
20101 IF(XT2.GE.1D0) THEN
20102 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20103 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20106 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20107 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20110 XT2=MAX(0.01D0*VINT(149),XT2)
20111 C...Use without "Sudakov" for high b values when impact parameter dep.
20113 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20114 & PYR(0)*(1D0-XC2))-VINT(149)
20115 XT2=MAX(0.01D0*VINT(149),XT2)
20119 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20120 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20121 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20122 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20125 VINT(21)=1D-12*VINT(149)
20128 VINT(25)=1D-12*VINT(149)
20131 C...Multiple interactions (first semihard interaction).
20132 C...Choose tau and y*. Calculate cos(theta-hat).
20133 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20134 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20135 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20137 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20143 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20144 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20145 CALL PYKMAP(2,MYST,PYR(0))
20146 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20148 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20150 C...Store results of cross-section calculation.
20151 ELSEIF(MMUL.EQ.4) THEN
20157 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20158 IF(ISET(ISUB).EQ.2)
20159 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20160 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20161 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20162 & (XTS+VINT(149))))
20163 IRBIN=INT(1D0+20D0*RBIN)
20164 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20165 NMUL(IRBIN)=NMUL(IRBIN)+1
20166 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20169 C...Choose impact parameter if not already done.
20170 ELSEIF(MMUL.EQ.5) THEN
20175 150 IF(MINT(39).GT.0) THEN
20176 ELSEIF(MSTP(82).EQ.3) THEN
20179 VINT(148)=EXPB2/(PARU(2)*VNT147)
20180 VINT(139)=SQRT(B2)/BAVG
20181 ELSEIF(MSTP(82).EQ.4) THEN
20183 IF(RTYPE.LT.P83A) THEN
20185 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20186 B2=-LOG(PYR(0))/CQ2R
20188 B2=-LOG(PYR(0))/CQ2I
20190 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20191 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20192 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20193 VINT(139)=SQRT(B2)/BAVG
20194 ELSEIF(PARP(83).GE.1.999D0) THEN
20195 POWIP=MAX(2D0,PARP(83))
20196 RPWIP=2D0/POWIP-1D0
20197 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20198 160 IF(PYR(0).LT.PROB1) THEN
20199 B2RPW=PYR(0)**(0.5D0*POWIP)
20202 B2RPW=1D0-LOG(PYR(0))
20205 IF(ACCIP.LT.PYR(0)) GOTO 160
20206 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20207 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20209 POWIP=MAX(0.4D0,PARP(83))
20210 RPWIP=2D0/POWIP-1D0
20211 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20212 170 IF(PYR(0).LT.PROB1) THEN
20213 B2RPW=2D0*RPWIP*PYR(0)
20214 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20216 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20217 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20219 IF(ACCIP.LT .PYR(0)) GOTO 170
20220 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20221 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20224 C...Multiple interactions (variable impact parameter) : reject with
20225 C...probability exp(-overlap*cross-section above pT/normalization).
20226 C...Does not apply to low-b region, where "Sudakov" already included.
20228 IF(MINT(39).NE.1) THEN
20229 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20230 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20231 DO 180 IBIN=IRBIN+1,20
20232 RNCOR=RNCOR+NMUL(IBIN)
20233 SIGCOR=SIGCOR+SIGM(IBIN)
20235 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20236 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20237 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20238 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20240 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20241 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20242 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20243 IF(VINT(150).LT.PYR(0)) GOTO 150
20247 C...Generate additional multiple semihard interactions.
20248 ELSEIF(MMUL.EQ.6) THEN
20250 C...Save data for hardest initeraction, to be restored.
20267 C...Store data on hardest interaction.
20274 C...Change process to generate; sum of x values so far.
20277 VINT(143)=1D0-VINT(141)
20278 VINT(144)=1D0-VINT(142)
20282 C...Initialize factors for PDF reshaping.
20286 KFSBM=ISIGN(1,KFBEAM)
20288 C...Zero flavour content of incoming beam particle.
20292 C...Flavour content of baryon.
20293 IF(KFABM.GT.1000) THEN
20294 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20295 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20296 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20297 C...Flavour content of pi+-, K+-.
20298 ELSEIF(KFABM.EQ.211) THEN
20299 KFIVAL(JS,1)=KFSBM*2
20300 KFIVAL(JS,2)=-KFSBM
20301 ELSEIF(KFABM.EQ.321) THEN
20302 KFIVAL(JS,1)=-KFSBM*3
20303 KFIVAL(JS,2)=KFSBM*2
20304 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20307 C...Zero initial valence and companion content.
20312 C...Initiate listing of all incoming partons from two sides.
20314 DO 210 I=MINT(84)+1,N
20315 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20321 C...Decide whether quarks in hard scattering were valence or sea.
20322 IFL=K(IMI(JS,1,1),2)
20323 IF (IABS(IFL).GT.6) GOTO 230
20325 C...Get PDFs at X and Q2 of the parton shower initiator for the
20326 C...hard scattering.
20328 IF(MSTP(61).GE.1) THEN
20333 C...Note: XPSVC = x*pdf.
20335 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20339 C...Decide (Extra factor x cancels in the division).
20340 RVCS=PYR(0)*(SEA+VAL)
20342 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20343 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20345 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20346 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20347 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20348 IF(KFIVAL(JS,1).EQ.0) THEN
20349 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20350 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20351 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20352 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20354 IF(IVNOW.EQ.0) GOTO 220
20357 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20358 IF(KFIVAL(JS,1).EQ.0) THEN
20359 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20362 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20364 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20365 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20369 C...If sea, add opposite sign companion parton. Store X and I.
20371 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20372 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20373 C...Set pointer to companion
20374 IMI(JS,1,2)=-NVC(JS,-IFL)
20378 C...Update counter number of multiple interactions.
20382 C...Set up starting values for iteration in xT2.
20383 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
20384 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
20385 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
20386 & ISUBSV.NE.96)) THEN
20387 XT2=(1D0-VINT(141))*(1D0-VINT(142))
20390 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
20391 IF(ISET(ISUBSV).EQ.2)
20392 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20393 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
20395 IF(MSTP(82).LE.1) THEN
20396 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20397 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20398 & VINT(317)/(VINT(318)*VINT(320))
20399 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20401 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20402 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20407 C...Iterate downwards in xT2.
20408 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
20411 ELSEIF(MSTP(82).LE.1) THEN
20412 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20413 IF(XT2.LT.VINT(149)) GOTO 440
20415 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
20416 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20417 & LOG(PYR(0)))-VINT(149)
20418 IF(XT2.LE.0D0) GOTO 440
20419 XT2=MAX(0.01D0*VINT(149),XT2)
20423 C...Choose tau and y*. Calculate cos(theta-hat).
20424 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20425 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20426 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20428 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20431 C...New: require shat > 1.
20432 IF(TAU*VINT(2).LT.1D0) GOTO 240
20436 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20437 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20438 CALL PYKMAP(2,MYST,PYR(0))
20439 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20441 C...Check that x not used up. Accept or reject kinematical variables.
20442 X1M=SQRT(TAU)*EXP(VINT(22))
20443 X2M=SQRT(TAU)*EXP(-VINT(22))
20444 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
20445 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20446 CALL PYSIGH(NCHN,SIGS)
20447 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20448 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
20449 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
20451 C...Reset K, P and V vectors.
20459 PT=0.5D0*VINT(1)*SQRT(XT2)
20461 C...Choose flavour of reacting partons (and subprocess).
20466 ICONMI=ISIG(ICHN,3)
20467 RSIGS=RSIGS-SIGH(ICHN)
20468 IF(RSIGS.LE.0D0) GOTO 280
20471 C...Reassign to appropriate process codes.
20472 280 ISUBMI=ICONMI/10
20473 ICONMI=MOD(ICONMI,10)
20475 C...Choose new quark flavour for annihilation graphs
20476 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
20478 CALL PYWIDT(21,SH,WDTP,WDTE)
20479 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
20480 DO 300 I=1,MDCY(21,3)
20481 KFLF=KFDP(I+MDCY(21,2)-1,1)
20482 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
20483 IF(RKFL.LE.0D0) GOTO 310
20485 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
20486 IF(KFLF.GE.4) GOTO 290
20487 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
20490 ELSEIF(ISUBMI.EQ.53) THEN
20496 C...Final state flavours and colour flow: default values
20503 IF(ISUBMI.EQ.11) THEN
20504 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
20506 IF(KFL1*KFL2.LT.0) KCC=KCC+2
20508 ELSEIF(ISUBMI.EQ.12) THEN
20509 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
20510 KFL3=ISIGN(KFLF,KFL1)
20514 ELSEIF(ISUBMI.EQ.13) THEN
20515 C...f + fbar -> g + g; th arbitrary
20520 ELSEIF(ISUBMI.EQ.28) THEN
20521 C...f + g -> f + g; th = (p(f)-p(f))**2
20522 IF(KFL1.EQ.21) JS=2
20524 IF(KFL1.EQ.21) KCC=KCC+2
20525 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
20526 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
20528 ELSEIF(ISUBMI.EQ.53) THEN
20529 C...g + g -> f + fbar; th arbitrary
20530 KCS=(-1)**INT(1.5D0+PYR(0))
20531 KFL3=ISIGN(KFLF,KCS)
20535 ELSEIF(ISUBMI.EQ.68) THEN
20536 C...g + g -> g + g; th arbitrary
20538 KCS=(-1)**INT(1.5D0+PYR(0))
20541 C...Store flavours of scattering.
20549 C...Set flavours and mothers of scattering partons.
20558 K(N+1,3)=MINT(83)+1
20559 K(N+2,3)=MINT(83)+2
20563 C...Store colour connection indices.
20566 IF(KCS.EQ.-1) JC=3-J
20567 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
20568 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
20569 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
20570 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
20573 C...Store incoming and outgoing partons in their CM-frame.
20574 SHR=SQRT(TAU)*VINT(1)
20577 P(N+2,3)=-0.5D0*SHR
20579 P(N+3,5)=PYMASS(K(N+3,2))
20580 P(N+4,5)=PYMASS(K(N+4,2))
20581 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
20582 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
20583 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
20584 P(N+4,4)=SHR-P(N+3,4)
20587 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
20589 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
20591 C...Set up default values before showers.
20592 MINT(31)=MINT(31)+1
20601 C...Showering of initial state partons (optional).
20602 C...Note: no showering of final state partons here; it comes later.
20603 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20610 KSAV(I,J)=K(N-4+I,J)
20611 PSAV(I,J)=P(N-4+I,J)
20614 CALL PYSSPA(IPU1,IPU2)
20616 C...If shower failed then restore to situation before shower.
20617 IF(MINT(51).GE.1) THEN
20621 K(N-4+I,J)=KSAV(I,J)
20622 P(N-4+I,J)=PSAV(I,J)
20632 C...Keep track of loose colour ends and information on scattering.
20633 370 IMI(1,MINT(31),1)=IPU1
20634 IMI(2,MINT(31),1)=IPU2
20635 IMI(1,MINT(31),2)=0
20636 IMI(2,MINT(31),2)=0
20637 XMI(1,MINT(31))=VINT(141)
20638 XMI(2,MINT(31))=VINT(142)
20639 PT2MI(MINT(31))=VINT(54)
20642 C...Decide whether quarks in last scattering were valence, companion or
20646 KFSBM=ISIGN(1,MINT(10+JS))
20647 IFL=K(IMI(JS,MINT(31),1),2)
20648 IMI(JS,MINT(31),2)=0
20649 IF (IABS(IFL).GT.6) GOTO 430
20651 C...Get PDFs at X and Q2 of the parton shower initiator for the
20652 C...last scattering. At this point VINT(143:144) do not yet
20653 C...include the scattered x values VINT(141:142).
20654 X=VINT(140+JS)/VINT(142+JS)
20655 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20660 C...Note: XPSVC = x*pdf.
20662 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20666 DO 380 IVC=1,NVC(JS,IFL)
20667 CMP=CMP+XPSVC(IFL,IVC)
20670 C...Decide (Extra factor x cancels in the dvision).
20671 RVCS=PYR(0)*(SEA+VAL+CMP)
20673 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20674 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20676 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20677 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20678 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20679 IF(KFIVAL(JS,1).EQ.0) THEN
20680 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20681 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20682 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20683 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20685 DO 400 I1=1,NMI(JS)
20686 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20690 IF(IVNOW.EQ.0) GOTO 390
20692 IMI(JS,MINT(31),2)=0
20693 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20694 IF(KFIVAL(JS,1).EQ.0) THEN
20695 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20698 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20700 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20701 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20705 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20706 C...If sea, add opposite sign companion parton. Store X and I.
20707 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20708 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20709 C...Set pointer to companion
20710 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20712 C...If companion, decide which one.
20716 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20717 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20718 C...Find original sea (anti-)quark:
20720 DO 420 I1=1,NMI(JS)
20721 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20722 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20723 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20724 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20727 C...Change X to what associated companion had, so that the correct
20728 C...amount of momentum can be subtracted from the companion sum below.
20729 X=XASSOC(JS,IFL,ISEL)
20730 C...Mark companion read.
20731 XASSOC(JS,IFL,ISEL)=0D0
20735 C...Global statistics.
20736 MINT(351)=MINT(351)+1
20737 VINT(351)=VINT(351)+PT
20738 IF (MINT(351).EQ.1) VINT(356)=PT
20740 C...Update remaining energy and other counters.
20741 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20742 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20748 VINT(151)=VINT(151)+VINT(41)
20749 VINT(152)=VINT(152)+VINT(42)
20750 VINT(143)=VINT(143)-VINT(141)
20751 VINT(144)=VINT(144)-VINT(142)
20753 C...Iterate, with more interactions allowed.
20754 IF(MINT(31).LT.240) GOTO 240
20757 C...Restore saved quantities for hardest interaction.
20773 C...Format statements for printout.
20774 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20775 &'actions for MSTP(82) =',I2,' ******')
20776 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20777 &D9.2,' mb: rejected')
20778 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20779 &D9.2,' mb: accepted')
20784 C*********************************************************************
20787 C...Finds left-behind remnant flavour content and hooks up
20788 C...the colour flow between the hard scattering and remnants
20792 C...Double precision and integer declarations.
20793 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20794 IMPLICIT INTEGER(I-N)
20795 INTEGER PYK,PYCHGE,PYCOMP
20796 C...The event record
20797 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20799 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20800 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20801 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20802 COMMON/PYINT1/MINT(400),VINT(400)
20803 C...The common block of dangling ends
20804 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20805 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20806 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20808 C...Local variables
20809 PARAMETER (NERSIZ=4000)
20810 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20812 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20813 SAVE /PYCBLS/,/PYCTAG/
20814 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20815 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20818 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)
20820 C...Set up error checkers
20823 C...Initialize colour arrays: MCO (Original) and MCT (New)
20824 DO 110 I=MINT(84)+1,NERSIZ
20829 C...Also zero colour tracing information, if existed.
20831 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20832 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20836 C...Initialize colour tag collapse arrays:
20837 C...JCCO (Original) and JCCN (New).
20838 DO 130 MG=MINT(84)+1,NERSIZ
20845 C...Zero gluon insertion array
20852 C...Compute hard scattering system rapidities
20853 IF (MSTP(89).EQ.1) THEN
20855 IF (IM.LE.MINT(31)) THEN
20856 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20858 C...Set (unsigned) rapidity = 100 for beam remnant systems.
20864 C...Treat each side separately
20867 C...Initialize side.
20870 KFS=ISIGN(1,MINT(10+JS))
20872 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20873 IF(KFIVAL(JS,1).EQ.0) THEN
20874 IF(MINT(10+JS).EQ.111) THEN
20875 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20876 KFIVAL(JS,2)=-KFIVAL(JS,1)
20877 ELSEIF(MINT(10+JS).EQ.22) THEN
20880 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20881 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20882 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20883 KFIVAL(JS,2)=-KFIVAL(JS,1)
20884 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20885 IF(PYR(0).GT.0.5D0) THEN
20895 C...Initialize beam remnant sea and valence content flavour by flavour.
20899 C...Count up original number of JFA valence quarks and antiquarks.
20904 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20905 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20907 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20908 C...Subtract kicked out valence and determine sea from flavour cons.
20909 DO 180 IM=1,NMI(JS)
20910 IFL = K(IMI(JS,IM,1),2)
20913 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20914 C...Subtract K.O. valence quark from remainder.
20916 JV=NVSUM(JS)-NVALQ-NVALQB
20917 IV(JS,JV)=IMI(JS,IM,1)
20918 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20919 C...Subtract K.O. valence antiquark from remainder.
20921 JV=NVSUM(JS)-NVALQ-NVALQB
20922 IV(JS,JV)=IMI(JS,IM,1)
20923 ELSEIF (IFA.EQ.JFA) THEN
20924 C...Outside sea without companion: add opposite sea flavour inside.
20925 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20928 C...Check if space left in PYJETS for additional BR flavours
20929 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20930 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20931 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20932 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20936 C...Add required val+sea content to beam remnant.
20937 IF (NFLSUM.GT.0) THEN
20939 C...Insert beam remnant quark as p.t. symbolic parton in ER.
20947 K(N,2)=ISIGN(JFA,NSEA)
20948 IF (IA.LE.NVALQ) K(N,2)=JFA
20949 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20951 C...Also update NMI, IMI, and IV arrays.
20953 IMI(JS,NMI(JS),1)=N
20954 IMI(JS,NMI(JS),2)=-1
20955 IF (IA.LE.NVALQ+NVALQB) THEN
20956 IMI(JS,NMI(JS),2)=0
20958 IV(JS,JV)=IMI(JS,NMI(JS),1)
20966 IF (IM.LE.NMI(JS)) THEN
20967 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20969 C...Add fictitious parent gluons for companion pairs.
20970 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20971 C...Randomly assign companions to sea quarks which have none.
20972 IF (IMI(JS,IM,2).LT.0) THEN
20974 230 IMC=MOD(IMC,NMI(JS))+1
20975 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20976 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20977 IMI(JS, IM,2) = IMI(JS,IMC,1)
20978 IMI(JS,IMC,2) = IMI(JS, IM,1)
20980 C...Add fictitious parent gluon
20990 C...Set gluon (anti-)colour daughter pointers
20991 K(N,4)=IMI(JS, IM,1)
20992 K(N,5)=IMI(JS, IM,2)
20993 C...Set quark (anti-)colour parent pointers
20994 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
20995 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
20996 C...Add gluon to IMI
20998 IMI(JS,NMI(JS),1)=N
20999 IMI(JS,NMI(JS),2)=0
21004 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21005 C...Set up initial v-v-j-v configuration. Otherwise set up
21006 C...mesonic v-vbar configuration
21007 IF (IABS(MINT(10+JS)).GT.1000) THEN
21008 C...Determine junction type (1: B=1 2: B=-1)
21009 ITJUNC(JS) = (3-KFS)/2
21010 C...Insert junction.
21017 C...Set special junction codes:
21020 C...Set parent to side.
21022 K(N,4)=ITJUNC(JS)*MSTU(5)
21024 C...Connect valence quarks to junction.
21027 C...Set (anti)colour mother = junction.
21029 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21031 C...Keep track of partons adjacent to junction:
21032 JST(JS,JV)=IV(JS,JV)
21035 C...Mesons: set up initial q-qbar topology
21037 IF (K(IV(JS,1),2).GT.0) THEN
21048 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21049 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21050 C...Special for mesons. Insert gluon if BR empty.
21051 IF (NBRTOT(JS).EQ.0) THEN
21065 C...Add gluon to IMI
21067 IMI(JS,NMI(JS),1)=N
21068 IMI(JS,NMI(JS),2)=0
21073 C...Count up number of valence quarks outside BR.
21075 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21076 & MOUT(JS)=MOUT(JS)+1
21081 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21082 C...v(g)vbar (mesonic) configuration.
21084 C...Create colour line tags starting from initiators.
21086 DO 320 IM=1,MINT(31)
21087 C...Consider each side in turn.
21092 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21094 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21097 CALL PYCTTR(I1,KCS,I2)
21098 IF(MINT(51).NE.0) RETURN
21105 C...Create colour tags for beam remnant partons.
21106 DO 330 IM=MINT(31)+1,NMI(JS)
21108 IF (K(IP,2).NE.21) THEN
21109 JC=(3-ISIGN(1,K(IP,2)))/2
21110 IF (MCT(IP,JC).EQ.0) THEN
21119 C...Fictituous gluons just inherit from their quark daughters.
21123 C...Real beam remnant gluons get their own colours
21134 C...Create colour tags for colour lines which are detached from the
21138 DO 350 I=MINT(84)+1,N
21140 C...Look for coloured string endpoint, or (later) leftover gluon.
21141 IF (K(I,1).NE.3) GOTO 350
21143 IF(KC.EQ.0) GOTO 350
21145 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21147 C...Pick up loose string end with no previous tag.
21149 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21150 IF(MCT(I,KCS-3).NE.0) GOTO 350
21152 CALL PYCTTR(I,KCS,I)
21153 IF(MINT(51).NE.0) RETURN
21158 C...Store original colour tags
21159 DO 370 I=MINT(84)+1,N
21164 C...Iteratively add gluons to already existing string pieces, enforcing
21165 C...various possible orderings, and rejecting insertions that would give
21166 C...rise to singlet gluons.
21167 C...<kappa tau> normalization.
21172 C...Set up simplified kinematics.
21173 C...Boost hard interaction systems.
21175 DO 380 IM=1,MINT(31)
21176 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21177 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21179 C...Assign preliminary beam remnant momenta.
21180 DO 390 I=MINT(53)+1,N
21184 IF (K(I,2).NE.88) THEN
21185 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21187 IF (JS.EQ.2) P(I,3)=-P(I,3)
21189 C...Junctions are wildcards for the present.
21195 C...Reset colour processing information.
21196 400 DO 410 I=MINT(84)+1,N
21197 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21198 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21203 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21204 IF (ITJUNC(JS).EQ.0) THEN
21205 JC1=MCT(JST(JS,1),1)
21206 JC2=MCT(JST(JS,2),2)
21208 JCCO(NCC,1)=MAX(JC1,JC2)
21209 JCCO(NCC,2)=MIN(JC1,JC2)
21210 C...Collapse colour tags in event record
21211 DO 420 I=MINT(84)+1,N
21212 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21213 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21219 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21220 IF (NG(JS).GT.0) THEN
21223 C...Start at random gluon (optimizes speed for random attachments)
21225 IMGL=PYR(0)*NMI(JS)+1
21226 450 IMGL=MOD(IMGL,NMI(JS))+1
21228 C...Only loop through NMI once (with upper limit to save time)
21229 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21230 IGL = IMI(JS,IMGL,1)
21231 C...If not gluon or if already connected, try next.
21232 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21233 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21234 C...Now loop through all possible insertions of this gluon.
21236 IMP1=PYR(0)*NMI(JS)+1
21237 460 IMP1=MOD(IMP1,NMI(JS))+1
21239 IF (IMP1.EQ.IMGL) GOTO 460
21240 C...Only loop through NMI once (with upper limit to save time).
21241 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21242 IP1 = IMI(JS,IMP1,1)
21243 C...Try both colour mother and colour anti-mother.
21244 C...Randomly select which one to try first.
21247 470 MANTI=MOD(MANTI+1,2)
21249 IF (NANTI.LE.2) THEN
21250 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21251 C...Reject if no appropriate mother (or if mother is fictitious
21253 IF (IP2.LE.0) GOTO 470
21254 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21255 C...Also reject if this link has already been tried.
21256 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21257 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21258 C...Set flag to indicate that this link has now been tried for this
21259 C...gluon. IP2 may be junction, which has several mothers.
21260 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21261 IF (K(IP2,2).NE.88) THEN
21262 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21265 C...JCG1: Original colour tag of gluon on IP1 side
21266 C...JCG2: Original colour tag of gluon on IP2 side
21267 C...JCP1: Original colour tag of IP1 on gluon side
21268 C...JCP2: Original colour tag of IP2 on gluon side.
21269 JCG1=MCO(IGL,2-MANTI)
21270 JCG2=MCO(IGL,1+MANTI)
21271 JCP1=MCO(IP1,1+MANTI)
21272 JCP2=MCO(IP2,2-MANTI)
21274 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21275 C...Reject gluon attachments that give rise to singlet gluons.
21276 IF (MACCPT.EQ.0) GOTO 470
21279 JCG1=MCT(IGL,2-MANTI)
21280 JCG2=MCT(IGL,1+MANTI)
21281 JCP1=MCT(IP1,1+MANTI)
21282 JCP2=MCT(IP2,2-MANTI)
21284 C...Select whether to accept this insertion
21285 IF (MSTP(89).EQ.0) THEN
21286 C...Random insertions: no measure.
21288 C...For random ordering, we want to suppress beam remnant breakups
21289 C...already at this point.
21290 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21291 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21296 ELSEIF (MSTP(89).EQ.1) THEN
21297 C...Rapidity ordering:
21298 C...YGL = Rapidity of gluon.
21300 C...If fictitious gluon
21301 IF (YGL.EQ.100D0) THEN
21303 IDA1=MOD(K(IGL,4),MSTU(5))
21304 IDA2=MOD(K(IGL,5),MSTU(5))
21305 DO 480 IMT=1,NMI(JS)
21306 C...Select (arbitrarily) the most central daughter.
21307 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21309 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21313 C...YP1 = Rapidity IP1
21315 C...If fictitious gluon
21316 IF (YP1.EQ.100D0) THEN
21318 IDA1=MOD(K(IP1,4),MSTU(5))
21319 IDA2=MOD(K(IP1,5),MSTU(5))
21320 DO 490 IMT=1,NMI(JS)
21321 C...Select (arbitrarily) the most central daughter.
21322 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21324 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21328 C...YP2 = Rapidity of mother system
21329 IF (K(IP2,2).NE.88) THEN
21330 DO 500 IMT=1,NMI(JS)
21331 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21333 C...If fictitious gluon
21334 IF (YP2.EQ.100D0) THEN
21336 IDA1=MOD(K(IP2,4),MSTU(5))
21337 IDA2=MOD(K(IP2,5),MSTU(5))
21338 DO 510 IMT=1,NMI(JS)
21339 C...Select (arbitrarily) the most central daughter.
21340 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21342 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21346 C...Assign (arbitrarily) 100D0 to junction also
21350 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21351 ELSEIF (MSTP(89).EQ.2) THEN
21352 C...Lambda ordering:
21353 C...Compute lambda measure for this insertion.
21358 C...If IP2 is junction, not caught below.
21359 IF (JCP2.EQ.0) THEN
21360 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
21361 C...Anti-junction is colour endpoint et vv., always on JCG2.
21364 DO 530 I=MINT(84)+1,N
21365 IF (K(I,1).LT.10) THEN
21366 C...The new string pieces
21367 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
21368 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
21369 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
21370 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
21373 C...Also identify junctions as string endpoints.
21374 DO 540 I=MINT(84)+1,N
21375 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
21376 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
21377 C...Find partons adjacent to junctions.
21378 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
21379 & .EQ.0) ISTR(2) = ICMO
21380 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
21381 & .EQ.0) ISTR(1) = IAMO
21382 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
21383 & .EQ.0) ISTR(4) = ICMO
21384 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
21385 & .EQ.0) ISTR(3) = IAMO
21387 C...The old string piece
21388 ISTR(5)=ISTR(1+2*MANTI)
21389 ISTR(6)=ISTR(4-2*MANTI)
21390 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
21391 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
21394 C...Allow some breadth to speed things up.
21395 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
21397 ELSEIF (RL.GT.RLOPT) THEN
21403 C...INSR(NOPT,1)=Gluon colour mother
21404 C...INSR(NOPT,2)=Gluon
21405 C...INSR(NOPT,3)=Gluon anticolour mother
21406 IF (NOPT.GT.1000) GOTO 470
21407 INSR(NOPT,1+2*MANTI)=IP2
21409 INSR(NOPT,3-2*MANTI)=IP1
21410 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
21412 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
21414 C...Reset link test information.
21415 DO 550 I=MINT(84)+1,N
21416 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21417 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21419 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
21421 C...Now we have a list of best gluon insertions, none of which cause
21422 C...singlets to arise. If list is empty, try again a few times. Note:
21423 C...this should never happen if we have a meson with a gluon inserted
21424 C...in the beam remnant, since that breaks up the colour line.
21425 IF (NOPT.EQ.0) THEN
21426 C...Abandon BR-g-BR suppression for retries. This is not serious, it
21427 C...just means we happened to start with trying a bad sequence.
21429 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
21430 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
21433 IF (ITJUNC(JS).NE.0) THEN
21437 C...Reset valence quark parent pointers
21438 DO 560 I=MINT(53)+1,N
21439 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
21442 C...Set (anti)colour mother = junction.
21444 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21448 C...Same for mesons. JST unchanged, so needn't be restored.
21451 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21452 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21454 C...Also reset gluon parent pointers.
21456 DO 580 IM=1,NMI(JS)
21458 IF (K(I,2).EQ.21) THEN
21459 K(I,4)=MOD(K(I,4),MSTU(5))
21460 K(I,5)=MOD(K(I,5),MSTU(5))
21465 C...Reset colour tags
21466 DO 600 I=MINT(84)+1,N
21472 IF(NERRPR.LT.5) THEN
21475 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
21476 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
21478 C...Kill event and start another.
21483 C...Select between insertions, suppressing insertions wholly in the BR.
21485 610 IIN=MOD(IIN,NOPT)+1
21486 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
21487 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
21490 C...Now we know which gluon to insert where. Colour tags in JCCO and
21491 C...colour connection information should be updated, NG(JS) should be
21492 C...counted down, and a new loop performed if there are still gluons
21493 C...left on any side.
21497 C...JCG : Original gluon colour tag
21498 C...JCAG: Original gluon anticolour tag.
21499 C...JCM : Original anticolour tag of gluon colour mother
21500 C...JACM: Original colour tag of gluon anticolour mother
21506 CALL PYMIHG(JACM,JACG,JCM,JCG)
21507 IF (MACCPT.EQ.0) THEN
21508 IF(NERRPR.LT.5) THEN
21511 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
21512 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
21514 C...Kill event and start another.
21518 C...If everything went fine, store new JCCN in JCCO.
21521 JCCO(ICC,1)=JCCN(ICC,1)
21522 JCCO(ICC,2)=JCCN(ICC,2)
21526 C...One gluon attached is counted as equivalent to one end outside.
21528 C...Set IGL colour mother = ICM.
21529 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
21530 C...Set ICM anticolour mother = IGL colour.
21531 IF (K(ICM,2).NE.88) THEN
21532 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
21534 C...If ICM is junction, just update JST array for now.
21536 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
21539 C...Set IGL anticolour mother = IACM.
21540 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
21541 C...Set IACM anticolour mother = IGL anticolour.
21542 IF (K(IACM,2).NE.88) THEN
21543 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
21545 C...If IACM is junction, just update JST array for now.
21547 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
21550 C...Count down # unconnected gluons.
21553 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
21556 C...Collapse fictitious gluons.
21557 DO 670 IGL=MINT(53)+1,N
21558 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
21559 & K(IGL,1).EQ.14) THEN
21560 ICM=K(IGL,4)/MSTU(5)
21561 IAM=K(IGL,5)/MSTU(5)
21562 ICD=MOD(K(IGL,4),MSTU(5))
21563 IAD=MOD(K(IGL,5),MSTU(5))
21564 C...Set gluon daughters pointing to gluon mothers
21565 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
21566 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
21567 C...Set gluon mothers pointing to gluon daughters.
21568 IF (K(ICM,2).NE.88) THEN
21569 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
21571 C...Special case: mother=junction. Just update JST array for now.
21573 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
21576 IF (K(IAM,2).NE.88) THEN
21577 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
21580 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
21586 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
21589 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
21590 IF (IM.GT.MINT(31)) THEN
21592 DO 690 IMR=IM,NMI(JS)
21593 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21594 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21599 C...Finally, connect junction.
21600 IF (ITJUNC(JS).NE.0) THEN
21601 DO 700 I=MINT(53)+1,N
21602 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21604 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21609 C...Find jq with no glue inbetween inside beam remnant.
21610 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21613 C...Set IDQ = -I if q non-valence and = +I if q valence.
21614 IDQ(NBRJQ)=-JST(JS,MSJ)
21616 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21617 IDQ(NBRJQ)=JST(JS,MSJ)
21624 IF (MSJ.EQ.3) I45=4
21625 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21628 C...Check if diquark can be formed.
21629 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21631 C...If there is less than 2 valence quarks connected to junction
21632 C...and MSTP(88)>1, use random non-valence quarks to fill up.
21633 IF (NBRVQ.LE.1) THEN
21635 730 JFLIP=NBRJQ*PYR(0)+1
21636 IF (IDQ(JFLIP).LT.0) THEN
21637 IDQ(JFLIP)=-IDQ(JFLIP)
21640 IF (NDIQ.LE.1) GOTO 730
21642 C...Place selected quarks first in IDQ, ordered in flavour.
21644 IF (IDQ(JDQ).LE.0) THEN
21648 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21655 C...Choose diquark spin.
21656 IF (NBRVQ.EQ.2) THEN
21657 C...If the selected quarks are both valence, we may use SU(6) rules
21658 C...to figure out which spin the diquark has, by a subdivision of the
21659 C...original beam hadron into the selected diquark system plus a kicked
21660 C...out quark, IKO.
21664 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21668 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21670 C...If one or more of the selected quarks are not valence, we cannot use
21671 C...SU(6) subdivisions of the original beam hadron. Instead, with the
21672 C...flavours of the diquark already selected, we assume for now
21673 C...50:50 spin-1:spin-0 (where spin-0 possible).
21674 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21676 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21677 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21678 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21681 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21682 C...Note: third quark can per definition not also be valence,
21683 C...therefore we can only do this if we are allowed to use sea quarks.
21684 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21687 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21688 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21690 ELSEIF(NTRY.GT.100) THEN
21691 C...If no baryon can be found, give up and form diquark.
21695 C...Replace junction by baryon.
21698 K(IJU,3)=MINT(83)+JS
21701 P(IJU,5)=PYMASS(KFBAR)
21703 C...Prepare removal of participating quarks from ER.
21704 K(JST(JS,MSJ),1)=-1
21708 C...If collapse to baryon not possible or not allowed, replace junction
21709 C...by diquark. This way, collapsed gluons that were pointing at the
21710 C...junction will now point (correctly) at diquark.
21714 K(IJU,3)=MINT(83)+JS
21719 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21721 K(IJU,5-MANTI)=IP*MSTU(5)
21722 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21724 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21726 C...Prepare removal of participating quarks from ER.
21732 C...Update so ER pointers to collapsed quarks
21733 C...now go to collapsed object.
21734 DO 820 I=MINT(84)+1,N
21735 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21736 & .K(I,1).GT.0) THEN
21738 IMO=K(I,ISID)/MSTU(5)
21739 IDA=MOD(K(I,ISID),MSTU(5))
21741 IF (K(IMO,1).EQ.-1) IMO=IJU
21744 IF (K(IDA,1).EQ.-1) IDA=IJU
21746 K(I,ISID)=IDA+MSTU(5)*IMO
21753 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21754 C...(this only happens for baryons, where we want to force the gluon
21755 C...to sit next to the junction. Mesons handled above.)
21756 IF (NBRTOT(JS).EQ.0) THEN
21766 K(IGL,3)=MINT(83)+JS
21767 IF (ITJUNC(JS).NE.0) THEN
21768 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21769 JLEG=PYR(0)*NVSUM(JS)+1
21772 JCT=MCT(I1,ITJUNC(JS))
21773 MCT(IGL,3-ITJUNC(JS))=JCT
21775 MCT(IGL,ITJUNC(JS))=NCT
21778 C...Meson. Should not happen.
21779 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21780 IF(NERRPR.LT.5) THEN
21781 WRITE(MSTU(11),*) 'This should not have been possible!'
21788 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21789 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21790 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21791 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21792 IF (K(I2,2).NE.88) THEN
21793 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21795 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21796 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21797 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21798 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21800 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21806 C...Remove collapsed quarks and junctions from ER and update IMI.
21809 C...Also update beam remnant part of IMI.
21812 DO 850 I=MINT(53)+1,N
21813 IF (K(I,1).LE.0) GOTO 850
21814 C...Restore BR quark/diquark/baryon pointers in IMI.
21815 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21818 IMI(JS,NMI(JS),1)=I
21819 IMI(JS,NMI(JS),2)=0
21823 C...Restore companion information from collapsed gluons.
21824 DO 870 I=MINT(53)+1,N
21825 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21827 JCD=MOD(K(I,4),MSTU(5))
21828 JAD=MOD(K(I,5),MSTU(5))
21829 DO 860 IM=1,NMI(JS)
21830 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21831 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21833 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21834 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21838 C...Renumber colour lines (since some have disappeared)
21846 IF (MFOUND.EQ.0) JCD=JCD+1
21847 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21850 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21854 IF (I.LE.N) GOTO 890
21855 IF (JCT.LT.NCT) GOTO 880
21858 C...Reset hard interaction subsystems to their CM frames.
21859 IF (IBOOST.EQ.1) THEN
21860 DO 900 IM=1,MINT(31)
21861 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21862 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21864 C...Zero beam remnant longitudinal momenta and energies
21865 DO 910 I=MINT(53)+1,N
21871 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21872 C...Kill event and start another.
21879 C*********************************************************************
21882 C...Adapted from PYPREP.
21883 C...Assigns LHA1 colour tags to coloured partons based on
21884 C...K(I,4) and K(I,5) colour connection record.
21885 C...KCS negative signifies that a previous tracing should be continued.
21886 C...(in case the tag to be continued is empty, the routine exits)
21887 C...Starts at I and ends at I or IEND.
21888 C...Special considerations for systems with junctions.
21890 SUBROUTINE PYCTTR(I,KCS,IEND)
21891 C...Double precision and integer declarations.
21892 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21893 INTEGER PYK,PYCHGE,PYCOMP
21895 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21897 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21898 COMMON/PYINT1/MINT(400),VINT(400)
21899 C...The common block of colour tags.
21900 COMMON/PYCTAG/NCT,MCT(4000,2)
21901 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21905 C...Skip if parton not existing or does not have KCS
21906 IF (K(I,1).LE.0) GOTO 120
21908 IF (KC.EQ.0) GOTO 120
21910 IF (KQ.EQ.0) GOTO 120
21911 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21916 C...Set colour tag of first parton.
21922 IF (NCS.EQ.0) GOTO 120
21928 IF(NSTP.GT.4*N) THEN
21929 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21933 C...Finished if reached final-state triplet.
21934 IF(K(IA,1).EQ.3) THEN
21935 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21938 C...Also finished if reached junction.
21939 IF(K(IA,1).EQ.42) THEN
21943 C...GOTO next parton in colour space.
21945 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21946 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21948 IA=MOD(K(IB,KCS),MSTU(5))
21949 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21952 C...If KCS mother traced or KCS mother nonexistent, switch colour.
21953 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21954 & MSTU(5)).EQ.0) THEN
21958 C...Assign new colour tag on other side of old parton.
21961 C...Goto (new) KCS mother, set mother traced tag
21962 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21963 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21966 IF(IA.LE.0.OR.IA.GT.N) THEN
21967 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21968 IF(NERRPR.LT.5) THEN
21969 write(*,*) 'began at ',I
21970 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
21971 & ' NCS=',NCS,' MREV=',MREV
21978 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21979 & MSTU(5)).EQ.IB) THEN
21980 IF(MREV.EQ.1) KCS=9-KCS
21981 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21982 C...Set KSC mother traced tag for IA
21983 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21985 IF(MREV.EQ.0) KCS=9-KCS
21986 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
21987 C...Set KCS daughter traced tag for IA
21988 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
21990 C...Assign new colour tag
21992 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
21997 *********************************************************************
22000 C...Collapse JCP1 and connecting tags to JCG1.
22001 C...Collapse JCP2 and connecting tags to JCG2.
22003 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22004 C...Double precision and integer declarations.
22005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22006 IMPLICIT INTEGER(I-N)
22007 INTEGER PYK,PYCHGE,PYCOMP
22008 C...The event record
22009 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22011 COMMON/PYINT1/MINT(400),VINT(400)
22012 SAVE /PYJETS/,/PYINT1/
22013 C...Local variables
22014 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22015 COMMON /PYCTAG/NCT,MCT(4000,2)
22016 SAVE /PYCBLS/,/PYCTAG/
22018 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22019 C...in temporary tag collapse array JCCN. Only break up one connection.
22023 JCCN(ICC,1)=JCCO(ICC,1)
22024 JCCN(ICC,2)=JCCO(ICC,2)
22025 C...If there was a mother, it was previously connected to JCP1.
22026 C...Should be changed to JCP2.
22027 IF (MCLPS.EQ.0) THEN
22028 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22030 JCCN(ICC,1)=MAX(JCG2,JCP2)
22031 JCCN(ICC,2)=MIN(JCG2,JCP2)
22036 C...Also collapse colours on JCP1 side of JCG1
22037 IF (JCP1.NE.0) THEN
22038 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22039 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22041 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22042 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22045 C...Initialize event record colour tag array MCT array to MCO.
22046 DO 110 I=MINT(84)+1,N
22052 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22053 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22054 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22055 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22057 C...Skip if junction.
22058 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22059 C...Define starting point in tag space.
22060 C...JCA = previous tag
22061 C...JCO = present tag
22063 IF (MOD(IS,2).EQ.1) THEN
22067 ELSEIF (MOD(IS,2).EQ.0) THEN
22073 120 ITRACE=ITRACE+1
22074 IF (ITRACE.GT.1000) THEN
22075 C...NB: Proper error message should be defined here.
22077 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22078 MINT(57)=MINT(57)+1
22082 C...Collapse all JCN tags to JCALL
22083 DO 130 I=MINT(84)+1,N
22084 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22085 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22087 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22088 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22095 C...If possible, step from JCO to new tag JCN not equal to JCA.
22097 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22099 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22102 C...Iterate if new colour was arrived at, but don't go in circles.
22103 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22104 C...Change all JCN tags in MCO to JCALL in MCT.
22105 DO 150 I=MINT(84)+1,N
22106 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22107 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22108 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22109 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22114 DO 200 JCL=NCT,1,-1
22119 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22121 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22124 C...Overpaint all JCN with JCL
22125 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22126 DO 190 I=MINT(84)+1,N
22127 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22128 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22129 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22130 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22141 C*********************************************************************
22144 C...Picks primordial kT and shares longitudinal momentum among
22149 C...Double precision and integer declarations.
22150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22151 IMPLICIT INTEGER(I-N)
22152 INTEGER PYK,PYCHGE,PYCOMP
22153 C...The event record
22154 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22156 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22158 COMMON/PYINT1/MINT(400),VINT(400)
22159 C...The common block of colour tags.
22160 COMMON/PYCTAG/NCT,MCT(4000,2)
22161 C...The common block of dangling ends
22162 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22163 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22164 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22165 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22166 C...Local variables
22167 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22168 C...W(I,J)| J=0 | 1 | 2 |
22169 C... I=0 | Wrem**2 | W+ | W- |
22170 C... 1 | W1**2 | W1+ | W1- |
22171 C... 2 | W2**2 | W2+ | W2- |
22173 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)
22174 C...Tentative parametrization of <kT> as a function of Q.
22175 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22176 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22177 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22178 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22179 C...Lambda kinematic function.
22180 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22182 C...Beginning and end of beam remnant partons
22186 C...Loopback point if kinematic choices gives impossible configuration.
22190 C...Assign kT values on each side separately.
22193 C...First zero all kT on this side. Skip if no kT to generate.
22194 DO 110 IM=1,NMI(JS)
22195 P(IMI(JS,IM,1),1)=0D0
22196 P(IMI(JS,IM,1),2)=0D0
22198 IF(MSTP(91).LE.0) GOTO 180
22200 C...Now assign kT to each (non-collapsed) parton in IMI.
22201 DO 170 IM=1,NMI(JS)
22203 C...Select kT according to truncated gaussian or 1/kt6 tails.
22204 C...For first interaction, either use rms width = PARP(91) or fitted.
22207 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22212 C...For subsequent interactions and BR partons use fragmentation width.
22217 IF(NTRY.LE.100) THEN
22218 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22222 ELSEIF (MSTP(91).EQ.2) THEN
22223 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22224 & 'available, using MSTP(91)=1.')
22225 CALL PYGIVE('MSTP(91)=1')
22227 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22228 C...Use distribution with kt**6 tails, rms width = PARP(91).
22229 EPS=SQRT(3D0/2D0)*SIGMA
22230 C...Generate PTX and PTY separately, each propto 1/KT**6
22232 C...Decide which interval to try
22233 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22234 IF (PYR(0).LT.P12) THEN
22235 C...Use flat approx with accept/reject up to EPS.
22237 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22238 IF (PYR(0).GT.WT) GOTO 112
22240 C...Above EPS, use 1/kt**6 approx with accept/reject.
22241 PT=EPS/(PYR(0)**(1D0/5D0))
22242 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22243 IF (PYR(0).GT.WT) GOTO 112
22246 IF (PYR(0).GT.0.5D0) MSIGN=-1
22247 IF (IXY.EQ.1) PTX=MSIGN*PT
22248 IF (IXY.EQ.2) PTY=MSIGN*PT
22250 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22251 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22252 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22254 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22255 PT=SQRT(PTX**2+PTY**2)
22257 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22258 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22261 PT=SQRT(PTX**2+PTY**2)
22267 C...Compensation kicks, with varying degree of local anticorrelations.
22269 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22270 PTCX=-PTX/(NMI(JS)-1)
22271 PTCY=-PTY/(NMI(JS)-1)
22272 IF(ISUB.EQ.95) THEN
22273 PTCX=-PTX/(NMI(JS)-2)
22274 PTCY=-PTY/(NMI(JS)-2)
22276 DO 120 IMC=1,NMI(JS)
22277 IF (IMC.EQ.IM) GOTO 120
22278 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22279 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22280 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22282 ELSEIF (MCORR.GE.1) THEN
22285 C...Count up # of neighbours on either side
22287 130 IMO=K(IMO,MSID)/MSTU(5)
22288 IF (IMO.EQ.0) GOTO 140
22289 NNXT(MSID-3)=NNXT(MSID-3)+1
22290 C...Stop at quarks and junctions
22291 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22293 C...How should compensation be shared when unequal numbers on the
22294 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22295 NSUM=NNXT(1)+NNXT(2)
22298 C...Total momentum to be compensated on this side
22299 IF (NNXT(MSID-3).EQ.0) GOTO 160
22300 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22301 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22302 C...RS: compensation supression factor as we go out from parton I.
22303 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22304 C...since (for now) MSTP(90) provides enough variability.
22306 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22309 IMO=K(IMO,MSID)/MSTU(5)
22310 IF (IMO.EQ.0) GOTO 160
22312 IF (K(IMO,2).NE.88) THEN
22313 P(IMO,1)=P(IMO,1)+FAC*PTCX
22314 P(IMO,2)=P(IMO,2)+FAC*PTCY
22315 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22316 C...If we reach junction, divide out the kT that would have been
22317 C...assigned to the junction on each of its other legs.
22319 L1=MOD(K(IMO,4),MSTU(5))
22320 L2=K(IMO,5)/MSTU(5)
22321 L3=MOD(K(IMO,5),MSTU(5))
22322 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22323 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22324 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22325 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22326 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22327 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22328 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22329 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22335 C...End assignment of kT values to initiators and remnants.
22338 C...Check kinematics constraints for non-BR partons.
22339 DO 190 IM=1,MINT(31)
22340 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
22341 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
22342 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
22343 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
22344 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
22345 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
22346 IF(NTRY.GE.100) THEN
22347 C...Kill this event and start another.
22349 & '(PYMIRM:) No consistent (x,kT) sets found')
22357 C...Calculate W+ and W- available for combined remnant system.
22360 DO 200 IM=1,MINT(31)
22361 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
22362 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
22363 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
22364 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
22365 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
22367 C...Also store Wrem**2 = W+ * W-
22368 W(0,0)=W(0,1)*W(0,2)
22370 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
22371 IF(NTRY.GE.100) THEN
22372 C...Kill this event and start another.
22374 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22381 C...Assign unscaled x values to partons/hadrons in each of the
22382 C...beam remnants and calculate unscaled W+ and W- from them.
22388 DO 270 IM=MINT(31)+1,NMI(JS)
22394 C...Skip collapsed gluons and junctions. Reset.
22395 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
22396 IF (KFA.EQ.88) GOTO 270
22403 C...If gluon then only beam remnant, so takes all.
22406 C...If valence quark then use parametrized valence distribution.
22407 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
22409 C...If companion quark then derive from companion x.
22410 ELSEIF(KFA.LE.6) THEN
22412 C...If valence diquark then use two parametrized valence distributions.
22413 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22415 IVALQ(1)=ISIGN(KFA/1000,KF)
22416 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
22417 C...If valence+sea diquark then combine valence + companion choices.
22418 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22419 & ICOMP.LT.MSTU(5)) THEN
22420 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
22421 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
22423 IVALQ(1)=ISIGN(KFA/1000,KF)
22426 C...Extra code: workaround for diquark made out of two sea
22427 C...quarks, but where not (yet) ICOMP > MSTU(5).
22428 DO 220 IM1=1,MINT(31)
22429 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
22430 ICOMQ(2)=IMI(JS,IM1,1)
22434 C...If sea diquark then sum of two derived from companion x.
22435 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
22436 ICOMQ(1)=MOD(ICOMP,MSTU(5))
22437 ICOMQ(2)=ICOMP/MSTU(5)
22438 C...If meson or baryon then use fragmentation function.
22439 C...Somewhat arbitrary split into old and new flavour, but OK normally.
22441 KFL3=MOD(KFA/10,10)
22442 IF(MOD(KFA/1000,10).EQ.0) THEN
22443 KFL1=MOD(KFA/100,10)
22445 KFL1=MOD(KFA,10000)-10*KFL3-1
22446 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
22447 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
22449 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
22450 CALL PYZDIS(KFL1,KFL3,PR,X)
22454 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
22455 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
22456 C...In other baryons combine u and d from proton appropriately.
22457 IF(IVALQ(IQ).NE.0) THEN
22459 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
22460 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
22461 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
22463 IF(KFIVAL(JS,3).EQ.0) THEN
22465 C...Baryon with three identical quarks: mix u and d forms.
22466 ELSEIF(NVAL.EQ.3) THEN
22467 MDU=INT(PYR(0)+5D0/3D0)
22468 C...Baryon, one of two identical quarks: u form.
22469 ELSEIF(NVAL.EQ.2) THEN
22471 C...Baryon with two identical quarks, but not the one picked: d form.
22472 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
22473 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
22475 C...Baryon with three nonidentical quarks: mix u and d forms.
22477 MDU=INT(PYR(0)+5D0/3D0)
22480 IF(MDU.EQ.1) XPOW=3.5D0
22481 IF(MDU.EQ.2) XPOW=2D0
22483 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
22487 C...Calculation of x of companion quark.
22488 IF(ICOMQ(IQ).NE.0) THEN
22490 DO 240 IM1=1,MINT(31)
22491 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
22493 NPOW=MAX(0,MIN(4,MSTP(87)))
22494 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
22495 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
22496 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
22497 IF(CORR.LT.PYR(0)) GOTO 250
22502 C...Optionally enchance x of composite systems (e.g. diquarks)
22503 IF (KFA.GT.100) X=PARP(79)*X
22505 C...Store x. Also calculate light cone energies of each system.
22507 W(JS,JS)=W(JS,JS)+X
22508 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
22510 W(JS,JS)=W(JS,JS)*W(0,JS)
22511 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
22512 W(JS,0)=W(JS,1)*W(JS,2)
22515 C...Check W1 W2 < Wrem (can be done before rescaling, since W
22516 C...insensitive to global rescalings of the BR x values).
22517 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
22520 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
22522 ELSEIF (NTRYX.GT.100) THEN
22523 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
22524 MINT(57)=MINT(57)+1
22529 C...Compute x rescaling factors
22530 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
22531 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
22532 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
22534 IF (R1.LT.0.OR.R2.LT.0) THEN
22535 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
22536 MINT(57)=MINT(57)+1
22540 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
22546 C...Rescale BR x values.
22547 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
22548 XMI(1,IM)=XMI(1,IM)*R1
22549 XMI(2,IM)=XMI(2,IM)*R2
22552 C...Now we have a consistent set of x and kT values.
22553 C...First set up the initiators and their daughters correctly.
22554 DO 300 IM=1,MINT(31)
22557 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
22558 & (P(I1,2)+P(I2,2))**2
22559 PT12=P(I1,1)**2+P(I1,2)**2
22560 PT22=P(I2,1)**2+P(I2,2)**2
22562 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
22564 C...Energies (masses should be zero at this stage)
22565 P(I1,4)=SQRT(PT12+P(I1,3)**2)
22566 P(I2,4)=SQRT(PT22+P(I2,3)**2)
22568 C...Transverse 12 system initiator velocity:
22569 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
22570 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
22571 C...Boost to overall initiator system rest frame
22572 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
22573 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
22575 C...Compute phi,theta coordinates of I1 and rotate z axis.
22576 PHI=PYANGL(P(I1,1),P(I1,2))
22577 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
22578 IMIN=IMISEP(IM-1)+1
22579 C...(include documentation lines if MI = 1)
22580 IF (IM.EQ.1) IMIN=MINT(83)+5
22582 C...Rotate entire system in phi
22583 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
22584 C...Only rotate 12 system in theta
22585 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
22586 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
22588 C...Now boost entire system back to LAB
22589 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22590 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
22591 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
22596 C...For the beam remnant partons/hadrons, we only need to set pz and E.
22598 DO 310 IM=MINT(31)+1,NMI(JS)
22600 C...Skip collapsed gluons and junctions.
22601 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22602 IF (KFA.EQ.88) GOTO 310
22603 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22604 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22605 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22606 IF (JS.EQ.2) P(I,3)=-P(I,3)
22611 C...Documentation lines
22617 K(IN,3)=MINT(83)+JS
22624 MCT(IN,1)=MCT(IO,1)
22625 MCT(IN,2)=MCT(IO,2)
22628 C...Final state colour reconnections.
22629 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22631 C...Number of colour tags for which a recoupling will be tried.
22633 C...Number of recouplings to try
22641 IF (IITER.LE.PARP(78)*NTOT) THEN
22642 C...Select two colour tags at random
22643 C...NB: jj strings do not have colour tags assigned to them,
22644 C...thus they are as yet not affected by anything done here.
22646 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22651 C...Find final state partons with this (anti)colour
22652 DO 370 I=MINT(84)+1,N
22653 IF (K(I,1).EQ.3) THEN
22654 IF (MCT(I,1).EQ.JCT) IJ1=I
22655 IF (MCT(I,2).EQ.JCT) IJ2=I
22656 IF (MCT(I,1).EQ.KCT) IK1=I
22657 IF (MCT(I,2).EQ.KCT) IK2=I
22660 C...Only consider recouplings not involving junctions for now.
22661 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22663 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22664 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22665 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22668 C...Count up number of reconnections
22669 MINT(34)=MINT(34)+1
22671 IF (MINT(34).LE.1000) THEN
22674 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22678 IF (NRECP.LT.MINT(34)) GOTO 350
22680 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22686 C*********************************************************************
22689 C...Performs colour annealing.
22690 C...MSTP(95) : CR Type
22691 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22692 C... = 2 : Type I(no gg loops); hadron-hadron only
22693 C... = 3 : Type I(no gg loops); all beams
22694 C... = 4 : Type II(gg loops) ; hadron-hadron only
22695 C... = 5 : Type II(gg loops) ; all beams
22696 C... = 6 : Type S ; hadron-hadron only
22697 C... = 7 : Type S ; all beams
22698 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22699 C...Type S is driven by starting only from free triplets, not octets.
22700 C...A string piece remains unchanged with probability
22701 C... PKEEP = (1-PARP(78))**N
22702 C...This scaling corresponds to each string piece having to go through
22703 C...N other ones, each with probability PARP(78) for reconnection, where
22704 C...N is here chosen simply as the number of multiple interactions,
22705 C...for a rough scaling with the general level of activity.
22707 SUBROUTINE PYFSCR(IP)
22708 C...Double precision and integer declarations.
22709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22710 INTEGER PYK,PYCHGE,PYCOMP
22712 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22714 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22715 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22716 COMMON/PYINT1/MINT(400),VINT(400)
22717 C...The common block of colour tags.
22718 COMMON/PYCTAG/NCT,MCT(4000,2)
22719 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22721 C...MCN: Temporary storage of new colour tags
22722 DOUBLE PRECISION MCN(4000,2)
22724 C...Function to give four-product.
22725 FOUR(I,J)=P(I,4)*P(J,4)
22726 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22728 C...Check valid range of MSTP(95), local copy
22729 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22730 MSTP95=MOD(MSTP(95),10)
22731 C...Set whether CR allowed inside resonance systems or not
22732 C...(not implemented yet)
22734 C IF (MSTP(95).GE.10) MRESCR=0
22736 C...Check whether colour tags already defined
22737 IF (MINT(33).EQ.0) THEN
22738 C...Erase any existing colour tags for this event
22743 C...Create colour tags for this event
22745 IF (K(I,1).EQ.3) THEN
22748 IF (MCT(I,KCSIN-3).EQ.0) THEN
22749 CALL PYCTTR(I,KCSIN,I)
22754 C...Instruct PYPREP to use colour tags
22758 C...For MSTP(95) even, only apply to hadron-hadron
22759 IF (MOD(MSTP(95),2).EQ.0) THEN
22762 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22765 C...Initialize new tag array (but do not delete old yet)
22767 DO 130 I=MAX(1,IP),N
22772 C...For each final-state dipole, check whether string should be
22777 DO 140 I=MAX(1,IP),N
22778 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22779 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22781 IF (IC.NE.0.AND.IA.NE.0) THEN
22782 C...Chiefly consider large strings.
22783 PKEEP=(1D0-PARP(78))**MINT(31)
22784 IF (PYR(0).LE.PKEEP) THEN
22792 C...Loop over event record, starting from IP
22793 C...(Ignore junctions for now.)
22801 DO 230 I=MAX(1,IP),N
22802 IF (K(I,1).NE.3) GOTO 230
22803 C...Check colour charge
22804 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22805 IF (MCI.EQ.0) GOTO 230
22806 C...For Seattle algorithm, only start from partons with one dangling
22808 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22809 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22811 C... Find optimal partner
22817 C...Loop over I colour/anticolour, check whether already connected
22819 IF (MCN(I,ICL).NE.0) GOTO 220
22820 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22821 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22822 C...Check whether this is a dangling colour tag (ie to junction!)
22824 DO 180 J=MAX(1,IP),N
22825 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22827 IF (IFOUND.EQ.0) GOTO 220
22828 DO 210 J=MAX(1,IP),N
22829 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22830 C...Do not make direct connections between partons in same Beam Remnant
22832 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22834 C...Check colour charge
22835 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22836 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22837 C...Check for gluon loops
22839 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22841 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22842 & MCN(I,ICLA).NE.0) MGGSTR=1
22844 C...Loop over J colour/anticolour, check whether already connected
22846 IF (MCN(J,JCL).NE.0) GOTO 200
22847 IF (JCL.EQ.ICL) GOTO 200
22848 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22849 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22850 C...Check whether this is a dangling colour tag (ie to junction!)
22852 DO 190 J2=MAX(1,IP),N
22853 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22856 IF (IFOUND.EQ.0) GOTO 200
22857 C...Save connection with smallest lambda measure
22858 C...If best so far was a BR string and this is not, also save.
22859 C...If best so far was a gg string and this is not, also save.
22861 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22862 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22863 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22875 IF (JLOPT.NE.0) THEN
22876 C...Save pair with largest RLOPT so far
22877 IF (RLOPT.GE.RLMAX) THEN
22888 C...Save and iterate
22889 IF (ILMAX.GT.0) THEN
22891 MCN(ILMAX,ICMAX)=LCT
22892 MCN(JLMAX,JCMAX)=LCT
22893 IF (NLOOP.LE.2*(N-IP)) THEN
22896 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
22900 C...Save and exit. First check for leftover gluon(s)
22901 DO 260 I=MAX(1,IP),N
22902 C...Check colour charge
22903 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22904 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22905 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22906 C...Decide where to put left-over gluon (minimal insertion)
22909 DO 250 KCT=NCT+1,LCT
22910 DO 240 IT=MAX(1,IP),N
22911 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22912 IF (MCN(IT,1).EQ.KCT) IC=IT
22913 IF (MCN(IT,2).EQ.KCT) IA=IT
22915 RL=FOUR(IC,I)*FOUR(IA,I)
22916 IF (RL.LT.RLMAX) THEN
22923 MCN(I,1)=MCN(ICMAX,1)
22928 DO 270 I=MAX(1,IP),N
22929 C...Do not erase parton shower colour history
22930 IF (K(I,1).NE.3) GOTO 270
22931 C...Check colour charge
22932 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22933 IF (MCI.EQ.0) GOTO 270
22934 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22935 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22942 C*********************************************************************
22945 C...Handles diffractive and elastic scattering.
22949 C...Double precision and integer declarations.
22950 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22951 IMPLICIT INTEGER(I-N)
22952 INTEGER PYK,PYCHGE,PYCOMP
22954 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22957 COMMON/PYINT1/MINT(400),VINT(400)
22958 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22960 C...Reset K, P and V vectors. Store incoming particles.
22961 DO 110 JT=1,MSTP(126)+10
22981 P(I,J)=VINT(285+5*JT+J)
22986 C...Subprocess; kinematics.
22987 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
22988 PZ=SQRT(SQLAM)/(2D0*VINT(1))
22991 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
22994 C...Elastically scattered particle. (Except elastic GVMD states.)
22995 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
22996 & MINT(106+JT).NE.3)) THEN
23001 P(N,3)=PZ*(-1)**(JT+1)
23003 P(N,5)=SQRT(VINT(62+JT))
23005 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23006 C...distribution of decay products (in rho rest frame).
23007 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23009 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23013 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23014 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23015 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23016 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23017 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23018 140 CTHE=2D0*PYR(0)-1D0
23019 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23020 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23022 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23025 C...Diffracted particle: low-mass system to two particles.
23026 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23032 PMMAS=SQRT(VINT(62+JT))
23035 IF(NTRY.LT.20) THEN
23036 MINT(105)=MINT(102+JT)
23037 MINT(109)=MINT(106+JT)
23038 CALL PYSPLI(KFH,21,KFL1,KFL2)
23039 CALL PYKFDI(KFL1,0,KFL3,KF1)
23040 IF(KF1.EQ.0) GOTO 150
23041 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23042 IF(KF2.EQ.0) GOTO 150
23049 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23054 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23055 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23058 P(N-1,4)=SQRT(PM1**2+PZP**2)
23059 P(N,4)=SQRT(PM2**2+PZP**2)
23060 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23062 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23063 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23065 C...Diffracted particle: valence quark kicked out.
23066 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23073 MINT(105)=MINT(102+JT)
23074 MINT(109)=MINT(106+JT)
23075 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23076 P(N-1,5)=PYMASS(K(N-1,2))
23077 P(N,5)=PYMASS(K(N,2))
23078 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23079 & 4D0*P(N-1,5)**2*P(N,5)**2
23080 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23081 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23082 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23083 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23084 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23086 C...Diffracted particle: gluon kicked out.
23095 MINT(105)=MINT(102+JT)
23096 MINT(109)=MINT(106+JT)
23097 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23099 P(N-2,5)=PYMASS(K(N-2,2))
23101 P(N,5)=PYMASS(K(N,2))
23102 C...Energy distribution for particle into two jets.
23104 IF(MOD(KFH/1000,10).NE.0) IMB=2
23105 CHIK=PARP(92+2*IMB)
23106 IF(MSTP(92).LE.1) THEN
23107 IF(IMB.EQ.1) CHI=PYR(0)
23108 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23109 ELSEIF(MSTP(92).EQ.2) THEN
23110 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23111 ELSEIF(MSTP(92).EQ.3) THEN
23112 CUT=2D0*0.3D0/VINT(1)
23114 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23116 ELSEIF(MSTP(92).EQ.4) THEN
23117 CUT=2D0*0.3D0/VINT(1)
23118 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23119 180 CHIR=CUT*CUTR**PYR(0)
23120 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23121 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23123 CUT=2D0*0.3D0/VINT(1)
23124 CUTA=CUT**(1D0-PARP(98))
23125 CUTB=(1D0+CUT)**(1D0-PARP(98))
23126 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23127 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23128 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23130 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23131 & VINT(62+JT)) GOTO 160
23132 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23133 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23134 & (2D0*VINT(62+JT))
23135 PEI=SQRT(PZI**2+SQM)
23136 PQQP=(1D0-CHI)*(PEI+PZI)
23137 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23138 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23139 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23140 P(N-1,3)=P(N-1,4)*(-1)**JT
23141 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23142 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23145 C...Documentation lines.
23147 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23148 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23149 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23151 P(I+2,3)=PZ*(-1)**(JT+1)
23153 P(I+2,5)=SQRT(VINT(62+JT))
23156 C...Rotate outgoing partons/particles using cos(theta).
23157 IF(VINT(23).LT.0.9D0) THEN
23158 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23160 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23166 C*********************************************************************
23169 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23170 C...and showering added consecutively. Photon flux by the PYGAGA
23171 C...routine (if at all).
23175 C...Double precision and integer declarations.
23176 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23177 IMPLICIT INTEGER(I-N)
23178 INTEGER PYK,PYCHGE,PYCOMP
23179 C...Parameter statement to help give large particle numbers.
23180 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23181 &KEXCIT=4000000,KDIMEN=5000000)
23183 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23184 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23185 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23186 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23188 COMMON/PYINT1/MINT(400),VINT(400)
23189 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23193 C...Choice of subprocess, number of documentation lines
23201 IF(MINT(107).EQ.4) ISIDE=2
23203 C...Reset K, P and V vectors. Store incoming particles
23204 DO 110 JT=1,MSTP(126)+20
23217 P(I,J)=VINT(285+5*JT+J)
23222 C...Store incoming partons in hadronic CM-frame
23227 K(I,3)=MINT(83)+2+JT
23229 IF(MINT(15).EQ.22) THEN
23230 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23231 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23232 P(MINT(84)+1,5)=-SQRT(VINT(307))
23233 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23234 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23238 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23239 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23240 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23241 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23242 P(MINT(84)+1,5)=-SQRT(VINT(308))
23246 SIDESG=(-1D0)**(ISIDE-1)
23248 C...Copy incoming partons to documentation lines.
23259 C...Second copy for partons before ISR shower, since no such.
23269 C...Define initial partons.
23272 IF(NTRY.GT.100) THEN
23277 C...Scattered quark in hadronic CM frame.
23282 P(IPU3,5)=PYMASS(KFRES)
23283 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
23284 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
23288 K(I,3)=MINT(83)+4+ISIDE
23296 C...No primordial kT, or chosen according to truncated Gaussian or
23297 C...exponential, or (for photon) predetermined or power law.
23298 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
23299 IF(MSTP(91).LE.0) THEN
23301 ELSEIF(MSTP(91).EQ.1) THEN
23302 PT=PARP(91)*SQRT(-LOG(PYR(0)))
23306 PT=-PARP(92)*LOG(RPT1*RPT2)
23308 IF(PT.GT.PARP(93)) GOTO 190
23309 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
23310 PTA=SQRT(VINT(282+ISIDE))
23312 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
23313 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
23314 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
23317 PTB=-PARP(99)*LOG(RPT1*RPT2)
23319 IF(PTB.GT.PARP(100)) GOTO 190
23320 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
23321 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
23322 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
23323 IF(MSTP(93).LE.0) THEN
23325 ELSEIF(MSTP(93).EQ.1) THEN
23326 PT=PARP(99)*SQRT(-LOG(PYR(0)))
23327 ELSEIF(MSTP(93).EQ.2) THEN
23330 PT=-PARP(99)*LOG(RPT1*RPT2)
23331 ELSEIF(MSTP(93).EQ.3) THEN
23334 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
23338 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
23339 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
23341 IF(PT.GT.PARP(100)) GOTO 190
23347 P(IPU3,1)=PT*COS(PHI)
23348 P(IPU3,2)=PT*SIN(PHI)
23349 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
23350 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
23351 PCP=P(IPU3,4)+ABS(P(IPU3,3))
23353 C...Find one or two beam remnants.
23354 MINT(105)=MINT(102+ISIDE)
23355 MINT(109)=MINT(106+ISIDE)
23356 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
23357 IF(MINT(51).NE.0) THEN
23362 C...Store first remnant parton, with colour info and kinematics.
23366 K(I,3)=MINT(83)+ISIDE
23367 P(I,5)=PYMASS(K(I,2))
23368 KCOL=KCHG(PYCOMP(KFLSP),2)
23371 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
23372 K(I,KFLS+3)=MSTU(5)*IPU3
23373 K(IPU3,6-KFLS)=MSTU(5)*I
23376 IF(KFLCH.EQ.0) THEN
23379 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23381 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
23382 PRP=P(I,4)+ABS(P(I,3))
23384 C...When extra remnant parton or hadron: store extra remnant.
23389 K(I,3)=MINT(83)+ISIDE
23390 P(I,5)=PYMASS(K(I,2))
23391 KCOL=KCHG(PYCOMP(KFLCH),2)
23394 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
23395 K(I,KFLS+3)=MSTU(5)*IPU3
23396 K(IPU3,6-KFLS)=MSTU(5)*I
23400 C...Relative transverse momentum when two remnants.
23403 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
23404 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
23405 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
23406 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
23407 P(I,1)=-P(IPU3,1)-P(I-1,1)
23408 P(I,2)=-P(IPU3,2)-P(I-1,2)
23409 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23411 C...Relative distribution of energy for particle into jet plus particle.
23413 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
23414 IF(MSTP(94).LE.1) THEN
23415 IF(IMB.EQ.1) CHI=PYR(0)
23416 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23417 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23418 ELSEIF(MSTP(94).EQ.2) THEN
23419 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
23420 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23421 ELSEIF(MSTP(94).EQ.3) THEN
23422 CALL PYZDIS(1,0,PMS(4),ZZ)
23425 CALL PYZDIS(1000,0,PMS(4),ZZ)
23429 C...Construct total transverse mass; reject if too large.
23430 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
23431 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
23432 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
23433 IF(LOOP.LT.10) GOTO 200
23436 VINT(158+ISIDE)=CHI
23438 C...Subdivide longitudinal momentum according to value selected above.
23439 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
23441 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
23442 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
23444 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
23445 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
23449 C...Boost current and remnant systems to correct frame.
23450 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
23451 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
23452 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
23454 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
23456 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
23457 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
23458 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
23459 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
23461 C...Let current quark shower; recoil but no showering by colour partner.
23462 QMAX=2D0*SQRT(VINT(309-ISIDE))
23467 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
23474 C*********************************************************************
23477 C...Handles the documentation of the process in MSTI and PARI,
23478 C...and also computes cross-sections based on accumulated statistics.
23482 C...Double precision and integer declarations.
23483 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23484 IMPLICIT INTEGER(I-N)
23485 INTEGER PYK,PYCHGE,PYCOMP
23487 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23489 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23490 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23491 COMMON/PYINT1/MINT(400),VINT(400)
23492 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23493 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
23494 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
23497 C...Calculate Monte Carlo estimates of cross-sections.
23499 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
23500 NGEN(0,3)=NGEN(0,3)+1
23503 IF(I.EQ.96.OR.I.EQ.97) THEN
23505 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
23506 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
23507 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23508 & DBLE(NGEN(96,2)))
23509 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
23510 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23511 & DBLE(NGEN(96,2)))
23512 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
23514 ELSEIF(NGEN(I,2).EQ.0) THEN
23515 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
23518 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
23521 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
23524 C...Rescale to known low-pT cross-section for standard QCD processes.
23525 IF(MSUB(95).EQ.1) THEN
23526 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
23527 & XSEC(68,3)+XSEC(95,3)
23528 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
23529 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
23531 XSEC(11,3)=FAC*XSEC(11,3)
23532 XSEC(12,3)=FAC*XSEC(12,3)
23533 XSEC(13,3)=FAC*XSEC(13,3)
23534 XSEC(28,3)=FAC*XSEC(28,3)
23535 XSEC(53,3)=FAC*XSEC(53,3)
23536 XSEC(68,3)=FAC*XSEC(68,3)
23537 XSEC(95,3)=FAC*XSEC(95,3)
23538 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
23542 C...Save information for gamma-p and gamma-gamma.
23543 IF(MINT(121).GT.1) THEN
23549 C...Reset information on hard interaction.
23555 C...Copy integer valued information from MINT into MSTI.
23559 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
23561 C...Store cross-section variables in PARI.
23563 PARI(2)=XSEC(0,3)/MINT(5)
23567 VINT(98)=VINT(98)+VINT(100)
23568 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
23570 C...Store kinematics variables in PARI.
23573 IF(ISUB.NE.95) THEN
23583 PARI(35)=PARI(33)-PARI(34)
23590 PARI(42)=2D0*VINT(47)/VINT(1)
23593 C...Store information on scattered partons in PARI.
23594 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
23597 PARI(36+IS)=P(I,3)/VINT(1)
23598 PARI(38+IS)=P(I,4)/VINT(1)
23599 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23600 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23601 & SQRT(PR),1D20)),P(I,3))
23602 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23603 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23604 & SQRT(PR),1D20)),P(I,3))
23605 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23606 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23607 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23611 C...Store sum up transverse and longitudinal momenta.
23612 PARI(65)=2D0*PARI(17)
23613 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23614 DO 150 I=MSTP(126)+1,N
23615 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23616 PT=SQRT(P(I,1)**2+P(I,2)**2)
23617 PARI(69)=PARI(69)+PT
23618 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23619 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23631 C...Store various other pieces of information into PARI.
23639 C...Store information on lepton -> lepton + gamma in PYGAGA.
23642 PARI(101)=VINT(301)
23643 PARI(102)=VINT(302)
23645 PARI(I)=VINT(I+202)
23648 C...Set information for PYTABU.
23649 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23652 ELSEIF(ISET(ISUB).EQ.5) THEN
23663 C*********************************************************************
23666 C...Performs transformations between different coordinate frames.
23668 SUBROUTINE PYFRAM(IFRAME)
23670 C...Double precision and integer declarations.
23671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23672 IMPLICIT INTEGER(I-N)
23673 INTEGER PYK,PYCHGE,PYCOMP
23675 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23676 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23677 COMMON/PYINT1/MINT(400),VINT(400)
23678 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23680 C...Check that transformation can and should be done.
23681 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23682 &MINT(91).EQ.1)) THEN
23683 IF(IFRAME.EQ.MINT(6)) RETURN
23685 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23689 IF(MINT(6).EQ.1) THEN
23690 C...Transform from fixed target or user specified frame to
23691 C...overall CM frame.
23692 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23693 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23694 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23695 ELSEIF(MINT(6).EQ.3) THEN
23696 C...Transform from hadronic CM frame in DIS to overall CM frame.
23697 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23701 IF(IFRAME.EQ.1) THEN
23702 C...Transform from overall CM frame to fixed target or user specified
23704 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23705 ELSEIF(IFRAME.EQ.3) THEN
23706 C...Transform from overall CM frame to hadronic CM frame in DIS.
23707 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23708 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23709 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23712 C...Set information about new frame.
23716 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23717 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23723 C*********************************************************************
23726 C...Calculates full and partial widths of resonances.
23728 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23730 C...Double precision and integer declarations.
23731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23732 IMPLICIT INTEGER(I-N)
23733 INTEGER PYK,PYCHGE,PYCOMP
23734 C...Parameter statement to help give large particle numbers.
23735 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23736 &KEXCIT=4000000,KDIMEN=5000000)
23738 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23739 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23740 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23741 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23742 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23743 COMMON/PYINT1/MINT(400),VINT(400)
23744 COMMON/PYINT4/MWID(500),WIDS(500,5)
23745 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23746 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23747 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23748 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23750 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23751 C...Local arrays and saved variables.
23752 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23753 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23754 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23755 SAVE MOFSV,WIDWSV,WID2SV
23756 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23758 C...Compressed code and sign; mass.
23765 C...Reset width information.
23766 DO 110 I=0,MDCY(KC,3)
23773 C...Allow for fudge factor to rescale resonance width.
23775 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23776 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23777 IF(MSTP(110).EQ.KFLA) THEN
23779 ELSEIF(MSTP(110).EQ.-1) THEN
23780 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23781 ELSEIF(MSTP(110).EQ.-2) THEN
23786 C...Not to be treated as a resonance: return.
23787 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23796 C...Treatment as a resonance based on tabulated branching ratios.
23797 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23798 C...Loop over possible decay channels; skip irrelevant ones.
23799 DO 120 I=1,MDCY(KC,3)
23801 IF(MDME(IDC,1).LT.0) GOTO 120
23803 C...Read out decay products and nominal masses.
23806 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23810 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23816 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23820 C...Naive partial width and alternative threshold factors.
23821 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23822 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23823 & PM1+PM2+PM3.GE.SHR) THEN
23825 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23826 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23827 & 4D0*PM1**2*PM2**2))/SH
23828 ELSEIF(MDME(IDC,2).EQ.52) THEN
23829 PMA=MAX(PM1,PM2,PM3)
23830 PMC=MIN(PM1,PM2,PM3)
23831 PMB=PM1+PM2+PM3-PMA-PMC
23832 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23837 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23838 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23839 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23840 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23841 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23842 & ((1D0-PMBCN)*PMBCN*SH)
23843 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23844 WDTP(I)=WDTP(I)*SQRT(
23845 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23846 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23847 ELSEIF(MDME(IDC,2).EQ.53) THEN
23848 PMA=MAX(PM1,PM2,PM3)
23849 PMC=MIN(PM1,PM2,PM3)
23850 PMB=PM1+PM2+PM3-PMA-PMC
23851 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23856 FACACT=SQRT(MAX(0D0,
23857 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23858 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23859 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23860 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23861 & ((1D0-PMBCN)*PMBCN*SH)
23862 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23866 PMBCN=PMBC**2/PMR**2
23867 FACNOM=SQRT(MAX(0D0,
23868 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23869 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23870 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23871 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23872 & ((1D0-PMBCN)*PMBCN*PMR**2)
23873 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23875 WDTP(I)=FUDGE*WDTP(I)
23876 WDTP(0)=WDTP(0)+WDTP(I)
23878 C...Calculate secondary width (at most two identical/opposite).
23880 IF(MDME(IDC,1).GT.0) THEN
23881 IF(KFD2.EQ.KFD1) THEN
23882 IF(KCHG(KFC1,3).EQ.0) THEN
23884 ELSEIF(KFD1.GT.0) THEN
23890 WID2=WID2*WIDS(KFC3,2)
23891 ELSEIF(KFD3.LT.0) THEN
23892 WID2=WID2*WIDS(KFC3,3)
23894 ELSEIF(KFD2.EQ.-KFD1) THEN
23897 WID2=WID2*WIDS(KFC3,2)
23898 ELSEIF(KFD3.LT.0) THEN
23899 WID2=WID2*WIDS(KFC3,3)
23901 ELSEIF(KFD3.EQ.KFD1) THEN
23902 IF(KCHG(KFC1,3).EQ.0) THEN
23904 ELSEIF(KFD1.GT.0) THEN
23910 WID2=WID2*WIDS(KFC2,2)
23911 ELSEIF(KFD2.LT.0) THEN
23912 WID2=WID2*WIDS(KFC2,3)
23914 ELSEIF(KFD3.EQ.-KFD1) THEN
23917 WID2=WID2*WIDS(KFC2,2)
23918 ELSEIF(KFD2.LT.0) THEN
23919 WID2=WID2*WIDS(KFC2,3)
23921 ELSEIF(KFD3.EQ.KFD2) THEN
23922 IF(KCHG(KFC2,3).EQ.0) THEN
23924 ELSEIF(KFD2.GT.0) THEN
23930 WID2=WID2*WIDS(KFC1,2)
23931 ELSEIF(KFD1.LT.0) THEN
23932 WID2=WID2*WIDS(KFC1,3)
23934 ELSEIF(KFD3.EQ.-KFD2) THEN
23937 WID2=WID2*WIDS(KFC1,2)
23938 ELSEIF(KFD1.LT.0) THEN
23939 WID2=WID2*WIDS(KFC1,3)
23948 WID2=WID2*WIDS(KFC2,2)
23950 WID2=WID2*WIDS(KFC2,3)
23953 WID2=WID2*WIDS(KFC3,2)
23954 ELSEIF(KFD3.LT.0) THEN
23955 WID2=WID2*WIDS(KFC3,3)
23959 C...Store effective widths according to case.
23960 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23961 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23962 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23963 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23973 C...Here begins detailed dynamical calculation of resonance widths.
23974 C...Shared treatment of Higgs states.
23977 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23982 C...Common electroweak and strong constants.
23985 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
23988 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
23990 RADC=1D0+AS/PARU(1)
23994 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23995 RADCT=1D0-2.5D0*AS/PARU(1)
23996 DO 140 I=1,MDCY(KC,3)
23998 IF(MDME(IDC,1).LT.0) GOTO 140
23999 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24000 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24001 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24003 IF(I.GE.4.AND.I.LE.7) THEN
24004 C...t -> W + q; including approximate QCD correction factor.
24005 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24006 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24007 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24010 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24013 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24015 ELSEIF(I.EQ.9) THEN
24017 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24018 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24019 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24020 & 4D0*SQRT(RM2R*RM2))
24022 IF(KFLR.LT.0) WID2=WIDS(37,3)
24024 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24025 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24028 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24031 KFC1=PYCOMP(KFDP(IDC,1))
24032 KFC2=PYCOMP(KFDP(IDC,2))
24033 PMNCHI=PMAS(KFC1,1)
24034 PMSTOP=PMAS(KFC2,1)
24035 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24038 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24040 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24041 AR=-ET*ZMIXC(IZ,1)*TANW
24042 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24044 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24045 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24046 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24047 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24048 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24049 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24050 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24052 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24054 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24057 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24059 KFC1=PYCOMP(KFDP(IDC,1))
24060 KFC2=PYCOMP(KFDP(IDC,2))
24061 PMNCHI=PMAS(KFC1,1)
24062 PMSTOP=PMAS(KFC2,1)
24063 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24066 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24067 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24068 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24069 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24071 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24073 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24076 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24077 C...t -> ~gravitino + ~t
24079 KFC1=PYCOMP(KFDP(IDC,1))
24080 XMGR2=PMAS(KFC1,1)**2
24081 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24082 KFC2=PYCOMP(KFDP(IDC,2))
24084 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24087 WDTP(I)=FUDGE*WDTP(I)
24088 WDTP(0)=WDTP(0)+WDTP(I)
24089 IF(MDME(IDC,1).GT.0) THEN
24090 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24091 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24092 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24093 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24097 ELSEIF(KFLA.EQ.7) THEN
24099 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24100 DO 150 I=1,MDCY(KC,3)
24102 IF(MDME(IDC,1).LT.0) GOTO 150
24103 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24104 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24105 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24107 IF(I.GE.4.AND.I.LE.7) THEN
24109 WDTP(I)=FAC*VCKM(I-3,4)*
24110 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24111 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24114 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24115 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24118 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24119 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24122 IF(KFLR.LT.0) WID2=WIDS(24,2)
24123 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24125 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24126 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24129 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24132 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24135 WDTP(I)=FUDGE*WDTP(I)
24136 WDTP(0)=WDTP(0)+WDTP(I)
24137 IF(MDME(IDC,1).GT.0) THEN
24138 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24139 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24140 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24141 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24145 ELSEIF(KFLA.EQ.8) THEN
24147 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24148 DO 160 I=1,MDCY(KC,3)
24150 IF(MDME(IDC,1).LT.0) GOTO 160
24151 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24152 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24153 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24155 IF(I.GE.4.AND.I.LE.7) THEN
24157 WDTP(I)=FAC*VCKM(4,I-3)*
24158 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24159 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24162 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24165 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24167 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24169 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24170 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24173 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24176 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24179 WDTP(I)=FUDGE*WDTP(I)
24180 WDTP(0)=WDTP(0)+WDTP(I)
24181 IF(MDME(IDC,1).GT.0) THEN
24182 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24183 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24184 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24185 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24189 ELSEIF(KFLA.EQ.17) THEN
24191 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24192 DO 170 I=1,MDCY(KC,3)
24194 IF(MDME(IDC,1).LT.0) GOTO 170
24195 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24196 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24197 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24200 C...tau' -> W + nu'_tau.
24201 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24202 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24205 WID2=WID2*WIDS(18,2)
24208 WID2=WID2*WIDS(18,3)
24210 ELSEIF(I.EQ.5) THEN
24211 C...tau' -> H + nu'_tau.
24212 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24213 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24216 WID2=WID2*WIDS(18,2)
24219 WID2=WID2*WIDS(18,3)
24222 WDTP(I)=FUDGE*WDTP(I)
24223 WDTP(0)=WDTP(0)+WDTP(I)
24224 IF(MDME(IDC,1).GT.0) THEN
24225 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24226 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24227 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24228 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24232 ELSEIF(KFLA.EQ.18) THEN
24233 C...nu'_tau neutrino.
24234 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24235 DO 180 I=1,MDCY(KC,3)
24237 IF(MDME(IDC,1).LT.0) GOTO 180
24238 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24239 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24240 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24243 C...nu'_tau -> W + tau'.
24244 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24245 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24248 WID2=WID2*WIDS(17,2)
24251 WID2=WID2*WIDS(17,3)
24253 ELSEIF(I.EQ.3) THEN
24254 C...nu'_tau -> H + tau'.
24255 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24256 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24259 WID2=WID2*WIDS(17,2)
24262 WID2=WID2*WIDS(17,3)
24265 WDTP(I)=FUDGE*WDTP(I)
24266 WDTP(0)=WDTP(0)+WDTP(I)
24267 IF(MDME(IDC,1).GT.0) THEN
24268 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24269 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24270 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24271 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24275 ELSEIF(KFLA.EQ.21) THEN
24277 C***Note that widths are not given in dimensional quantities here.
24278 DO 190 I=1,MDCY(KC,3)
24280 IF(MDME(IDC,1).LT.0) GOTO 190
24281 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24282 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24283 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
24286 C...QCD -> q + qbar
24287 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24288 IF(I.EQ.6) WID2=WIDS(6,1)
24289 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24291 WDTP(I)=FUDGE*WDTP(I)
24292 WDTP(0)=WDTP(0)+WDTP(I)
24293 IF(MDME(IDC,1).GT.0) THEN
24294 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24295 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24296 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24297 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24301 ELSEIF(KFLA.EQ.22) THEN
24303 C***Note that widths are not given in dimensional quantities here.
24304 DO 200 I=1,MDCY(KC,3)
24306 IF(MDME(IDC,1).LT.0) GOTO 200
24307 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24308 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24309 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
24312 C...QED -> q + qbar.
24315 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24316 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24317 IF(I.EQ.6) WID2=WIDS(6,1)
24318 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24319 ELSEIF(I.LE.12) THEN
24320 C...QED -> l+ + l-.
24321 EF=KCHG(9+2*(I-8),1)/3D0
24322 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24323 IF(I.EQ.12) WID2=WIDS(17,1)
24325 WDTP(I)=FUDGE*WDTP(I)
24326 WDTP(0)=WDTP(0)+WDTP(I)
24327 IF(MDME(IDC,1).GT.0) THEN
24328 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24329 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24330 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24331 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24335 ELSEIF(KFLA.EQ.23) THEN
24338 XWC=1D0/(16D0*XW*XW1)
24339 FAC=(AEM*XWC/3D0)*SHR
24341 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24346 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24348 IF(KFI.GT.20) KFI=IABS(MINT(16))
24354 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
24355 IF(MSTP(43).EQ.3) VINT(112)=
24356 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24357 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24358 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24360 DO 220 I=1,MDCY(KC,3)
24362 IF(MDME(IDC,1).LT.0) GOTO 220
24363 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24364 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24365 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
24370 AF=SIGN(1D0,EF+0.1D0)
24373 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24374 IF(I.EQ.6) WID2=WIDS(6,1)
24375 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24376 ELSEIF(I.LE.16) THEN
24377 C...Z0 -> l+ + l-, nu + nubar
24379 AF=SIGN(1D0,EF+0.1D0)
24382 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24384 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24385 IF(ICASE.EQ.1) THEN
24386 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
24388 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24389 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24390 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
24391 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
24392 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24393 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24394 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24395 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24397 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
24398 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
24399 IF(MDME(IDC,1).GT.0) THEN
24400 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24401 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24402 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24403 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24404 & WDTE(I,MDME(IDC,1))
24405 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24406 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24408 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24409 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
24410 & VINT(111)+FGGF*WID2
24411 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
24412 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24413 & VINT(114)+FZZF*WID2
24417 IF(MINT(61).GE.1) ICASE=3-ICASE
24418 IF(ICASE.EQ.2) GOTO 210
24420 ELSEIF(KFLA.EQ.24) THEN
24422 FAC=(AEM/(24D0*XW))*SHR
24423 DO 230 I=1,MDCY(KC,3)
24425 IF(MDME(IDC,1).LT.0) GOTO 230
24426 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24427 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24428 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
24431 C...W+/- -> q + qbar'
24432 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
24434 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24435 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24436 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24438 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24439 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24440 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24442 ELSEIF(I.LE.20) THEN
24443 C...W+/- -> l+/- + nu
24446 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24448 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24451 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24452 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24453 WDTP(I)=FUDGE*WDTP(I)
24454 WDTP(0)=WDTP(0)+WDTP(I)
24455 IF(MDME(IDC,1).GT.0) THEN
24456 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24457 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24458 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24459 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24463 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24464 C...h0 (or H0, or A0):
24466 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24467 DO 270 I=1,MDCY(KFHIGG,3)
24468 IDC=I+MDCY(KFHIGG,2)-1
24469 IF(MDME(IDC,1).LT.0) GOTO 270
24470 KFC1=PYCOMP(KFDP(IDC,1))
24471 KFC2=PYCOMP(KFDP(IDC,2))
24472 RM1=PMAS(KFC1,1)**2/SH
24473 RM2=PMAS(KFC2,1)**2/SH
24474 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
24480 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
24481 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
24482 C...A0 behaves like beta, ho and H0 like beta**3.
24483 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24484 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24485 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
24486 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
24487 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
24488 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
24489 IF(IHIGG.NE.3) THEN
24490 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24491 & PARU(151+10*IHIGG))**2
24495 IF(I.EQ.6) WID2=WIDS(6,1)
24496 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24497 ELSEIF(I.LE.12) THEN
24499 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
24500 C...A0 behaves like beta, ho and H0 like beta**3.
24501 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24502 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24503 & PARU(153+10*IHIGG)**2
24504 IF(I.EQ.12) WID2=WIDS(17,1)
24506 ELSEIF(I.EQ.13) THEN
24507 C...h0 -> g + g; quark loop contribution only
24510 DO 240 J=1,2*MSTP(1)
24511 EPS=(2D0*PMAS(J,1))**2/SH
24512 C...Loop integral; function of eps=4m^2/shat; different for A0.
24513 IF(EPS.LE.1D0) THEN
24514 IF(EPS.GT.1D-4) THEN
24516 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24518 RLN=LOG(4D0/EPS-2D0)
24520 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24521 PHIIM=0.5D0*PARU(1)*RLN
24523 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24526 IF(IHIGG.LE.2) THEN
24527 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24528 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
24530 ETAREJ=-0.5D0*EPS*PHIRE
24531 ETAIMJ=-0.5D0*EPS*PHIIM
24533 C...Couplings (=1 for standard model Higgs).
24534 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24535 IF(MOD(J,2).EQ.1) THEN
24536 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
24537 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
24539 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
24540 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
24546 ETA2=ETARE**2+ETAIM**2
24547 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
24549 ELSEIF(I.EQ.14) THEN
24550 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
24554 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24556 IF(J.LE.2*MSTP(1)) THEN
24558 EPS=(2D0*PMAS(J,1))**2/SH
24559 ELSEIF(J.LE.3*MSTP(1)) THEN
24560 JL=2*(J-2*MSTP(1))-1
24561 EJ=KCHG(10+JL,1)/3D0
24562 EPS=(2D0*PMAS(10+JL,1))**2/SH
24563 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24564 EPS=(2D0*PMAS(24,1))**2/SH
24566 EPS=(2D0*PMAS(37,1))**2/SH
24568 C...Loop integral; function of eps=4m^2/shat.
24569 IF(EPS.LE.1D0) THEN
24570 IF(EPS.GT.1D-4) THEN
24572 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24574 RLN=LOG(4D0/EPS-2D0)
24576 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24577 PHIIM=0.5D0*PARU(1)*RLN
24579 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24582 IF(J.LE.3*MSTP(1)) THEN
24583 C...Fermion loops: loop integral different for A0; charges.
24584 IF(IHIGG.LE.2) THEN
24585 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24586 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
24588 PHIPRE=-0.5D0*EPS*PHIRE
24589 PHIPIM=-0.5D0*EPS*PHIIM
24591 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24593 EJH=PARU(151+10*IHIGG)
24594 ELSEIF(J.LE.2*MSTP(1)) THEN
24596 EJH=PARU(152+10*IHIGG)
24599 EJH=PARU(153+10*IHIGG)
24601 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24602 ETAREJ=EJC*EJH*PHIPRE
24603 ETAIMJ=EJC*EJH*PHIPIM
24604 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24605 C...W loops: loop integral and charges.
24606 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24607 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24608 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24609 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24610 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24613 C...Charged H loops: loop integral and charges.
24614 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24615 & PARU(158+10*IHIGG+2*(IHIGG/3))
24616 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24617 ETAIMJ=-EPS**2*PHIIM*FACHHH
24622 ETA2=ETARE**2+ETAIM**2
24623 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24625 ELSEIF(I.EQ.15) THEN
24626 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24630 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24632 IF(J.LE.2*MSTP(1)) THEN
24634 AJ=SIGN(1D0,EJ+0.1D0)
24636 EPS=(2D0*PMAS(J,1))**2/SH
24637 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24638 ELSEIF(J.LE.3*MSTP(1)) THEN
24639 JL=2*(J-2*MSTP(1))-1
24640 EJ=KCHG(10+JL,1)/3D0
24641 AJ=SIGN(1D0,EJ+0.1D0)
24643 EPS=(2D0*PMAS(10+JL,1))**2/SH
24644 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24646 EPS=(2D0*PMAS(24,1))**2/SH
24647 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24649 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24650 IF(EPS.LE.1D0) THEN
24652 IF(EPS.GT.1D-4) THEN
24653 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24655 RLN=LOG(4D0/EPS-2D0)
24657 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24658 PHIIM=0.5D0*PARU(1)*RLN
24659 PSIRE=0.5D0*ROOT*RLN
24660 PSIIM=-0.5D0*ROOT*PARU(1)
24662 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24664 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24667 IF(EPSP.LE.1D0) THEN
24668 ROOT=SQRT(1D0-EPSP)
24669 IF(EPSP.GT.1D-4) THEN
24670 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24672 RLN=LOG(4D0/EPSP-2D0)
24674 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24675 PHIIMP=0.5D0*PARU(1)*RLN
24676 PSIREP=0.5D0*ROOT*RLN
24677 PSIIMP=-0.5D0*ROOT*PARU(1)
24679 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24681 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24684 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24685 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24686 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24687 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24688 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24689 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24690 IF(J.LE.3*MSTP(1)) THEN
24691 C...Fermion loops: loop integral different for A0; charges.
24692 IF(IHIGG.EQ.3) FXYRE=0D0
24693 IF(IHIGG.EQ.3) FXYIM=0D0
24694 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24696 EJH=PARU(151+10*IHIGG)
24697 ELSEIF(J.LE.2*MSTP(1)) THEN
24699 EJH=PARU(152+10*IHIGG)
24702 EJH=PARU(153+10*IHIGG)
24704 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24705 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24706 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24707 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24708 C...W loops: loop integral and charges.
24709 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24710 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24711 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24712 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24713 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24714 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24717 C...Charged H loops: loop integral and charges.
24718 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24719 & PARU(158+10*IHIGG+2*(IHIGG/3))
24720 ETAREJ=FACHHH*FXYRE
24721 ETAIMJ=FACHHH*FXYIM
24726 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24727 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24730 ELSEIF(I.LE.17) THEN
24731 C...h0 -> Z0 + Z0, W+ + W-
24732 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24733 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24734 IF(MINT(62).GE.1) THEN
24735 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24736 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24737 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24738 MOFSV(IHIGG,I-15)=0
24739 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24743 MOFSV(IHIGG,I-15)=1
24744 RMAS=SQRT(MAX(0D0,SH))
24745 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24747 WIDWSV(IHIGG,I-15)=WIDW
24748 WID2SV(IHIGG,I-15)=WID2
24751 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24752 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24756 WIDW=WIDWSV(IHIGG,I-15)
24757 WID2=WID2SV(IHIGG,I-15)
24760 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24761 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24762 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24763 & PARU(138+I+10*IHIGG)**2
24764 WID2=WID2*WIDS(7+I,1)
24766 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24767 C...H0 -> Z0 + h0, A0-> Z0 + h0
24768 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24769 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24770 IF(IHIGG.EQ.2) THEN
24771 WDTP(I)=WDTP(I)*PARU(179)**2
24772 ELSEIF(IHIGG.EQ.3) THEN
24773 WDTP(I)=WDTP(I)*PARU(186)**2
24775 WID2=WIDS(23,2)*WIDS(25,2)
24777 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24778 C...H0 -> h0 + h0, A0-> h0 + h0
24779 WDTP(I)=FAC*0.25D0*
24780 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24781 IF(IHIGG.EQ.2) THEN
24782 WDTP(I)=WDTP(I)*PARU(176)**2
24783 ELSEIF(IHIGG.EQ.3) THEN
24784 WDTP(I)=WDTP(I)*PARU(169)**2
24787 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24788 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24789 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24790 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24791 & *PARU(195+IHIGG)**2
24793 WID2=WIDS(24,2)*WIDS(37,3)
24794 ELSEIF(I.EQ.21) THEN
24795 WID2=WIDS(24,3)*WIDS(37,2)
24798 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24800 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24801 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24802 WID2=WIDS(36,2)*WIDS(23,2)
24804 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24806 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24807 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24808 WID2=WIDS(25,2)*WIDS(36,2)
24810 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24812 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24813 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24818 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24821 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24822 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24823 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24828 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24830 IF(KFC2.EQ.KFC1) THEN
24834 IF(KFDP(IDC,1).LT.0) KSGN1=3
24836 IF(KFDP(IDC,2).LT.0) KSGN2=3
24837 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24840 WDTP(I)=FUDGE*WDTP(I)
24841 WDTP(0)=WDTP(0)+WDTP(I)
24842 IF(MDME(IDC,1).GT.0) THEN
24843 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24844 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24845 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24846 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24850 ELSEIF(KFLA.EQ.32) THEN
24853 XWC=1D0/(16D0*XW*XW1)
24854 FAC=(AEM*XWC/3D0)*SHR
24857 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24865 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24866 KFAI=IABS(MINT(15))
24867 EI=KCHG(KFAI,1)/3D0
24868 AI=SIGN(1D0,EI+0.1D0)
24871 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24872 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24873 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24874 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24875 VPI=PARU(119+2*KFAIC)
24876 API=PARU(120+2*KFAIC)
24877 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24878 VPI=PARJ(178+2*KFAIC)
24879 API=PARJ(179+2*KFAIC)
24881 VPI=PARJ(186+2*KFAIC)
24882 API=PARJ(187+2*KFAIC)
24886 SQMZP=PMAS(32,1)**2
24888 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24889 & MSTP(44).EQ.7) VINT(111)=1D0
24890 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24891 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24892 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24893 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24894 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24895 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24896 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24897 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24898 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24899 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24900 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24902 DO 290 I=1,MDCY(KC,3)
24904 IF(MDME(IDC,1).LT.0) GOTO 290
24905 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24906 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24907 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24911 C...Z'0 -> q + qbar
24913 AF=SIGN(1D0,EF+0.1D0)
24916 VPF=PARU(123-2*MOD(I,2))
24917 APF=PARU(124-2*MOD(I,2))
24918 ELSEIF(I.LE.4) THEN
24919 VPF=PARJ(182-2*MOD(I,2))
24920 APF=PARJ(183-2*MOD(I,2))
24922 VPF=PARJ(190-2*MOD(I,2))
24923 APF=PARJ(191-2*MOD(I,2))
24926 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24927 & PYHFTH(SH,SH*RM1,1D0)
24928 IF(I.EQ.6) WID2=WIDS(6,1)
24929 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24930 ELSEIF(I.LE.16) THEN
24931 C...Z'0 -> l+ + l-, nu + nubar
24933 AF=SIGN(1D0,EF+0.1D0)
24936 VPF=PARU(127-2*MOD(I,2))
24937 APF=PARU(128-2*MOD(I,2))
24938 ELSEIF(I.LE.12) THEN
24939 VPF=PARJ(186-2*MOD(I,2))
24940 APF=PARJ(187-2*MOD(I,2))
24942 VPF=PARJ(194-2*MOD(I,2))
24943 APF=PARJ(195-2*MOD(I,2))
24946 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24948 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24949 IF(ICASE.EQ.1) THEN
24950 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24951 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24952 & APF**2*(1D0-4D0*RM1))*BE34
24953 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24954 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24955 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24956 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24957 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24958 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24959 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24960 ELSEIF(MINT(61).EQ.2) THEN
24961 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24962 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24963 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24964 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24965 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24967 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24970 ELSEIF(I.EQ.17) THEN
24972 WDTPZP=PARU(129)**2*XW1**2*
24973 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24974 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24975 IF(ICASE.EQ.1) THEN
24978 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24979 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24980 ELSEIF(MINT(61).EQ.2) THEN
24989 ELSEIF(I.EQ.18) THEN
24991 CZC=2D0*(1D0-2D0*XW)
24992 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24993 IF(ICASE.EQ.1) THEN
24994 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
24995 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
24996 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24997 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
24998 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
24999 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25000 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25001 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25002 ELSEIF(MINT(61).EQ.2) THEN
25004 FGZF=0.25D0*PARU(142)*CZC*BE34C
25005 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25006 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25007 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25008 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25011 ELSEIF(I.EQ.19) THEN
25012 C...Z'0 -> Z0 + gamma.
25013 ELSEIF(I.EQ.20) THEN
25015 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25016 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25017 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25018 IF(ICASE.EQ.1) THEN
25021 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25022 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25023 ELSEIF(MINT(61).EQ.2) THEN
25031 WID2=WIDS(23,2)*WIDS(25,2)
25032 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25033 C...Z' -> h0 + A0 or H0 + A0.
25034 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25042 IF(ICASE.EQ.1) THEN
25043 WDTPZ=CZAH**2*BE34C
25044 WDTP(I)=FAC*CZPAH**2*BE34C
25045 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25046 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25047 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25049 ELSEIF(MINT(61).EQ.2) THEN
25054 FZZPF=CZAH*CZPAH*BE34C
25055 FZPZPF=CZPAH**2*BE34C
25057 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25058 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25060 IF(ICASE.EQ.1) THEN
25061 VINT(117)=VINT(117)+FAC*WDTPZ
25062 WDTP(I)=FUDGE*WDTP(I)
25063 WDTP(0)=WDTP(0)+WDTP(I)
25065 IF(MDME(IDC,1).GT.0) THEN
25066 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25067 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25068 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25069 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25070 & WDTE(I,MDME(IDC,1))
25071 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25072 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25074 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25075 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25076 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25077 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25079 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25081 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25082 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25083 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25085 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25086 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25090 IF(MINT(61).GE.1) ICASE=3-ICASE
25091 IF(ICASE.EQ.2) GOTO 280
25093 ELSEIF(KFLA.EQ.34) THEN
25095 FAC=(AEM/(24D0*XW))*SHR
25096 DO 300 I=1,MDCY(KC,3)
25098 IF(MDME(IDC,1).LT.0) GOTO 300
25099 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25100 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25101 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25105 C...W'+/- -> q + qbar'
25106 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25107 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25109 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25110 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25111 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25113 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25114 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25115 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25117 ELSEIF(I.LE.20) THEN
25118 C...W'+/- -> l+/- + nu
25119 FCOF=PARU(133)**2+PARU(134)**2
25121 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25123 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25126 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25128 ELSEIF(I.EQ.21) THEN
25129 C...W'+/- -> W+/- + Z0
25130 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25131 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25132 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25133 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25134 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25135 ELSEIF(I.EQ.23) THEN
25136 C...W'+/- -> W+/- + h0
25137 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25138 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25139 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25140 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25142 WDTP(I)=FUDGE*WDTP(I)
25143 WDTP(0)=WDTP(0)+WDTP(I)
25144 IF(MDME(IDC,1).GT.0) THEN
25145 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25146 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25147 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25148 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25152 ELSEIF(KFLA.EQ.37) THEN
25154 C IF(MSTP(49).EQ.0) THEN
25157 C SHFS=PMAS(37,1)**2
25159 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25160 DO 310 I=1,MDCY(KC,3)
25162 IF(MDME(IDC,1).LT.0) GOTO 310
25163 KFC1=PYCOMP(KFDP(IDC,1))
25164 KFC2=PYCOMP(KFDP(IDC,2))
25165 RM1=PMAS(KFC1,1)**2/SH
25166 RM2=PMAS(KFC2,1)**2/SH
25167 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25170 C...H+/- -> q + qbar'
25171 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25172 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25173 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25174 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25175 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25177 IF(I.EQ.3) WID2=WIDS(6,2)
25178 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25180 IF(I.EQ.3) WID2=WIDS(6,3)
25181 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25183 ELSEIF(I.LE.8) THEN
25184 C...H+/- -> l+/- + nu
25185 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25186 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25187 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25189 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25191 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25193 ELSEIF(I.EQ.9) THEN
25194 C...H+/- -> W+/- + h0.
25195 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25196 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25197 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25198 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25202 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25205 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25206 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25207 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25212 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25215 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25217 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25218 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25220 WDTP(I)=FUDGE*WDTP(I)
25221 WDTP(0)=WDTP(0)+WDTP(I)
25222 IF(MDME(IDC,1).GT.0) THEN
25223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25230 ELSEIF(KFLA.EQ.41) THEN
25232 FAC=(AEM/(12D0*XW))*SHR
25233 DO 320 I=1,MDCY(KC,3)
25235 IF(MDME(IDC,1).LT.0) GOTO 320
25236 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25237 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25238 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25243 ELSEIF(I.LE.9) THEN
25247 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25248 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25250 IF(I.EQ.4) WID2=WIDS(6,3)
25251 IF(I.EQ.5) WID2=WIDS(7,3)
25252 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
25253 IF(I.EQ.9) WID2=WIDS(17,3)
25255 IF(I.EQ.4) WID2=WIDS(6,2)
25256 IF(I.EQ.5) WID2=WIDS(7,2)
25257 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
25258 IF(I.EQ.9) WID2=WIDS(17,2)
25260 WDTP(I)=FUDGE*WDTP(I)
25261 WDTP(0)=WDTP(0)+WDTP(I)
25262 IF(MDME(IDC,1).GT.0) THEN
25263 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25264 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25265 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25266 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25270 ELSEIF(KFLA.EQ.42) THEN
25271 C...LQ (leptoquark).
25272 FAC=(AEM/4D0)*PARU(151)*SHR
25273 DO 330 I=1,MDCY(KC,3)
25275 IF(MDME(IDC,1).LT.0) GOTO 330
25276 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25277 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25278 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
25279 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25281 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
25282 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
25283 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
25284 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
25285 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
25286 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
25287 WDTP(I)=FUDGE*WDTP(I)
25288 WDTP(0)=WDTP(0)+WDTP(I)
25289 IF(MDME(IDC,1).GT.0) THEN
25290 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25291 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25292 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25293 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25297 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
25298 C...Techni-pi0 and techni-pi0':
25299 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25300 DO 340 I=1,MDCY(KC,3)
25302 IF(MDME(IDC,1).LT.0) GOTO 340
25303 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25304 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25307 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
25311 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
25312 & /(8D0*PARU(1))*SH*SHR
25313 IF(KFLA.EQ.KTECHN+111) THEN
25320 C...pi_tc -> f + fbar.
25322 IKA=IABS(KFDP(IDC,1))
25323 IF(IKA.LT.10) FCOF=3D0*RADC
25326 IF(IKA.GE.4.AND.IKA.LE.6) THEN
25327 FCOF=FCOF*RTCM(1+IKA)**2
25328 HM1=PYMRUN(KFDP(IDC,1),SH)
25329 HM2=PYMRUN(KFDP(IDC,2),SH)
25330 ELSEIF(IKA.EQ.15) THEN
25331 FCOF=FCOF*RTCM(8)**2
25333 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25334 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25336 WDTP(I)=FUDGE*WDTP(I)
25337 WDTP(0)=WDTP(0)+WDTP(I)
25338 IF(MDME(IDC,1).GT.0) THEN
25339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25346 ELSEIF(KFLA.EQ.KTECHN+211) THEN
25348 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25349 DO 350 I=1,MDCY(KC,3)
25351 IF(MDME(IDC,1).LT.0) GOTO 350
25352 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25353 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25355 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25359 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
25361 C...pi_tc -> f + f'.
25363 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
25364 C...pi_tc+ -> W b b~
25365 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
25367 XMT2=PMAS(6,1)**2/SH
25368 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
25369 KFC3=PYCOMP(KFDP(IDC,3))
25370 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
25372 T0 = (1D0-CHECK**2)*
25373 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
25374 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
25375 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
25376 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
25377 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
25378 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
25387 IKA=IABS(KFDP(IDC,1))
25388 IF(IKA.LT.10) FCOF=3D0*RADC
25391 IF(I.GE.1.AND.I.LE.5) THEN
25393 FCOF=FCOF*RTCM(5)**2
25394 ELSEIF(I.LE.4) THEN
25395 FCOF=FCOF*RTCM(6)**2
25396 ELSEIF(I.EQ.5) THEN
25397 FCOF=FCOF*RTCM(7)**2
25399 HM1=PYMRUN(KFDP(IDC,1),SH)
25400 HM2=PYMRUN(KFDP(IDC,2),SH)
25401 ELSEIF(I.EQ.8) THEN
25402 FCOF=FCOF*RTCM(8)**2
25404 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25405 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25407 WDTP(I)=FUDGE*WDTP(I)
25408 WDTP(0)=WDTP(0)+WDTP(I)
25409 IF(MDME(IDC,1).GT.0) THEN
25410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25412 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25413 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25417 ELSEIF(KFLA.EQ.KTECHN+331) THEN
25419 FAC=(SH/PARP(46)**2)*SHR
25420 DO 360 I=1,MDCY(KC,3)
25422 IF(MDME(IDC,1).LT.0) GOTO 360
25423 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25424 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25425 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
25428 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
25429 IF(I.EQ.2) WID2=WIDS(6,1)
25431 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
25433 WDTP(I)=FUDGE*WDTP(I)
25434 WDTP(0)=WDTP(0)+WDTP(I)
25435 IF(MDME(IDC,1).GT.0) THEN
25436 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25437 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25438 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25439 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25443 ELSEIF(KFLA.EQ.KTECHN+113) THEN
25445 ALPRHT=2.16D0*(3D0/ITCM(1))
25446 FAC=(ALPRHT/12D0)*SHR
25447 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
25451 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25453 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25454 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25455 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25456 DO 370 I=1,MDCY(KC,3)
25458 IF(MDME(IDC,1).LT.0) GOTO 370
25459 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25460 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25461 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
25464 C...rho_tc0 -> W+ + W-.
25465 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25466 WDTP(I)=FAC*RTCM(3)**4*
25467 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25468 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25469 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25470 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
25472 ELSEIF(I.EQ.2) THEN
25473 C...rho_tc0 -> W+ + pi_tc-.
25474 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
25475 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25476 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25477 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25478 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
25479 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25480 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25481 ELSEIF(I.EQ.3) THEN
25482 C...rho_tc0 -> pi_tc+ + W-.
25483 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25484 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25485 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25486 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
25487 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25488 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
25489 ELSEIF(I.EQ.4) THEN
25490 C...rho_tc0 -> pi_tc+ + pi_tc-.
25491 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25492 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25493 WID2=WIDS(PYCOMP(KTECHN+211),1)
25494 ELSEIF(I.EQ.5) THEN
25495 C...rho_tc0 -> gamma + pi_tc0
25496 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25497 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25499 WID2=WIDS(PYCOMP(KTECHN+111),2)
25500 ELSEIF(I.EQ.6) THEN
25501 C...rho_tc0 -> gamma + pi_tc0'
25502 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25503 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
25504 WID2=WIDS(PYCOMP(KTECHN+221),2)
25505 ELSEIF(I.EQ.7) THEN
25506 C...rho_tc0 -> Z0 + pi_tc0
25507 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25508 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25510 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25511 ELSEIF(I.EQ.8) THEN
25512 C...rho_tc0 -> Z0 + pi_tc0'
25513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25514 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25516 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25517 ELSEIF(I.EQ.9) THEN
25518 C...rho_tc0 -> gamma + Z0
25519 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25520 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25522 ELSEIF(I.EQ.10) THEN
25523 C...rho_tc0 -> Z0 + Z0
25524 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25525 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
25529 C...rho_tc0 -> f + fbar.
25534 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25538 IF(IA.GE.17) WID2=WIDS(IA,1)
25541 AI=SIGN(1D0,EI+0.1D0)
25545 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25546 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25547 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25548 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25550 WDTP(I)=FUDGE*WDTP(I)
25551 WDTP(0)=WDTP(0)+WDTP(I)
25552 IF(MDME(IDC,1).GT.0) THEN
25553 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25554 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25555 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25556 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25560 ELSEIF(KFLA.EQ.KTECHN+213) THEN
25562 ALPRHT=2.16D0*(3D0/ITCM(1))
25563 FAC=(ALPRHT/12D0)*SHR
25567 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
25569 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
25570 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25571 DO 380 I=1,MDCY(KC,3)
25573 IF(MDME(IDC,1).LT.0) GOTO 380
25574 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25575 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25576 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
25578 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25579 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25582 C...rho_tc+ -> W+ + Z0.
25584 WDTP(I)=FAC*RTCM(3)**4*
25585 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25586 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
25587 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
25589 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
25592 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
25594 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25597 WID2=WIDS(24,2)*WIDS(23,2)
25599 WID2=WIDS(24,3)*WIDS(23,2)
25601 ELSEIF(I.EQ.2) THEN
25602 C...rho_tc+ -> W+ + pi_tc0.
25603 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25604 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25605 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25606 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25607 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25609 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
25611 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
25613 ELSEIF(I.EQ.3) THEN
25614 C...rho_tc+ -> pi_tc+ + Z0.
25615 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25616 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25617 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25618 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
25619 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
25620 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25621 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25624 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
25626 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25628 ELSEIF(I.EQ.4) THEN
25629 C...rho_tc+ -> pi_tc+ + pi_tc0.
25630 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25631 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25633 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25635 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25637 ELSEIF(I.EQ.5) THEN
25638 C...rho_tc+ -> pi_tc+ + gamma
25639 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25640 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25643 WID2=WIDS(PYCOMP(KTECHN+211),2)
25645 WID2=WIDS(PYCOMP(KTECHN+211),3)
25647 ELSEIF(I.EQ.6) THEN
25648 C...rho_tc+ -> W+ + pi_tc0'
25649 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25650 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25652 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25654 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25656 ELSEIF(I.EQ.7) THEN
25657 C...rho_tc+ -> W+ + gamma
25658 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25659 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25666 C...rho_tc+ -> f + fbar'.
25670 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25672 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25673 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25674 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25676 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25677 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25678 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25683 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25685 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25688 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25689 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25691 WDTP(I)=FUDGE*WDTP(I)
25692 WDTP(0)=WDTP(0)+WDTP(I)
25693 IF(MDME(IDC,1).GT.0) THEN
25694 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25695 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25696 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25697 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25701 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25703 ALPRHT=2.16D0*(3D0/ITCM(1))
25704 FAC=(ALPRHT/12D0)*SHR
25705 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25708 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25710 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25711 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25712 DO 390 I=1,MDCY(KC,3)
25714 IF(MDME(IDC,1).LT.0) GOTO 390
25715 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25716 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25717 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25720 C...omega_tc0 -> gamma + pi_tc0.
25721 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25722 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25723 WID2=WIDS(PYCOMP(KTECHN+111),2)
25724 ELSEIF(I.EQ.2) THEN
25725 C...omega_tc0 -> Z0 + pi_tc0
25726 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25727 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25729 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25730 ELSEIF(I.EQ.3) THEN
25731 C...omega_tc0 -> gamma + pi_tc0'
25732 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25733 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25735 WID2=WIDS(PYCOMP(KTECHN+221),2)
25736 ELSEIF(I.EQ.4) THEN
25737 C...omega_tc0 -> Z0 + pi_tc0'
25738 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25739 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25741 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25742 ELSEIF(I.EQ.5) THEN
25743 C...omega_tc0 -> W+ + pi_tc-
25744 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25745 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25746 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25747 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25748 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25749 ELSEIF(I.EQ.6) THEN
25750 C...omega_tc0 -> pi_tc+ + W-
25751 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25752 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25753 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25754 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25755 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25756 ELSEIF(I.EQ.7) THEN
25757 C...omega_tc0 -> W+ + W-.
25758 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25759 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25760 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25761 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25762 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
25764 ELSEIF(I.EQ.8) THEN
25765 C...omega_tc0 -> pi_tc+ + pi_tc-.
25766 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25767 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25768 WID2=WIDS(PYCOMP(KTECHN+211),1)
25769 C...omega_tc0 -> gamma + Z0
25770 ELSEIF(I.EQ.9) THEN
25771 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25772 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25774 C...omega_tc0 -> Z0 + Z0
25775 ELSEIF(I.EQ.10) THEN
25776 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25777 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
25778 & /24D0/RTCM(12)**2*SHR**3
25781 C...omega_tc0 -> f + fbar.
25786 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25790 IF(IA.GE.17) WID2=WIDS(IA,1)
25793 AI=SIGN(1D0,EI+0.1D0)
25795 VALI=-0.5D0*(VI+AI)
25796 VARI=-0.5D0*(VI-AI)
25797 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25798 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25799 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25800 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25802 WDTP(I)=FUDGE*WDTP(I)
25803 WDTP(0)=WDTP(0)+WDTP(I)
25804 IF(MDME(IDC,1).GT.0) THEN
25805 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25806 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25807 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25808 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25812 C.....V8 -> quark anti-quark
25813 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25816 IF(ITCM(2).EQ.0) THEN
25818 ELSEIF(ITCM(2).EQ.1) THEN
25821 DO 400 I=1,MDCY(KC,3)
25823 IF(MDME(IDC,1).LT.0) GOTO 400
25824 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25826 IF(RM1.GT.0.25D0) GOTO 400
25828 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25833 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25834 IF(I.EQ.6) WID2=WIDS(6,1)
25835 WDTP(I)=FUDGE*WDTP(I)
25836 WDTP(0)=WDTP(0)+WDTP(I)
25837 IF(MDME(IDC,1).GT.0) THEN
25838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25845 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25846 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25848 DO 410 I=1,MDCY(KC,3)
25850 IF(MDME(IDC,1).LT.0) GOTO 410
25851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25857 IF(KFLA.EQ.KTECHN+100111) THEN
25862 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25863 & /(2D0*PARU(1))*SH*SHR*CLEBG
25866 C...pi_tc -> f + fbar.
25867 IF(I.EQ.6) WID2=WIDS(6,1)
25869 IKA=IABS(KFDP(IDC,1))
25870 IF(IKA.LT.10) FCOF=3D0*RADC
25871 HM1=PYMRUN(KFDP(IDC,1),SH)
25872 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25873 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25875 WDTP(I)=FUDGE*WDTP(I)
25876 WDTP(0)=WDTP(0)+WDTP(I)
25877 IF(MDME(IDC,1).GT.0) THEN
25878 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25879 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25880 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25881 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25885 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25887 ALPRHT=2.16D0*(3D0/ITCM(1))
25889 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25890 SINT3=TANT3/SQRT(TANT3**2+1D0)
25893 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25894 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25895 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25896 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25897 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25899 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25901 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25903 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25905 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25906 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25907 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25908 IF(ITCM(2).EQ.0) THEN
25913 DO 420 I=1,MDCY(KC,3)
25914 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25915 & KFLA.EQ.KTECHN+300113)) GOTO 420
25917 IF(MDME(IDC,1).LT.0) GOTO 420
25918 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25919 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25920 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25923 IF(I.EQ.6) WID2=WIDS(6,1)
25925 IF(KFLA.EQ.KTECHN+200113) THEN
25928 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25931 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25936 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25937 FMIX=1D0/TANT3/SIN2T
25941 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25942 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25943 ELSEIF(I.EQ.7) THEN
25944 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25945 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25946 PSH=SHR*(1D0-RM1)/2D0
25947 WDTP(I)=AS/9D0*PSH**3/RM82
25949 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25950 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25952 WDTP(I)=5D0*WDTP(I)
25953 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25956 WDTP(I)=FUDGE*WDTP(I)
25957 WDTP(0)=WDTP(0)+WDTP(I)
25958 IF(MDME(IDC,1).GT.0) THEN
25959 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25960 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25961 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25962 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25966 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25967 C...d* excited quark.
25968 FAC=(SH/RTCM(41)**2)*SHR
25969 DO 430 I=1,MDCY(KC,3)
25971 IF(MDME(IDC,1).LT.0) GOTO 430
25972 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25973 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25974 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25978 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25980 ELSEIF(I.EQ.2) THEN
25981 C...d* -> gamma + d.
25982 QF=-RTCM(43)/2D0+RTCM(44)/6D0
25983 WDTP(I)=FAC*AEM*QF**2/4D0
25985 ELSEIF(I.EQ.3) THEN
25987 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25988 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25989 & (1D0-RM1)**2*(2D0+RM1)
25991 ELSEIF(I.EQ.4) THEN
25993 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25994 & (1D0-RM1)**2*(2D0+RM1)
25995 IF(KFLR.GT.0) WID2=WIDS(24,3)
25996 IF(KFLR.LT.0) WID2=WIDS(24,2)
25998 WDTP(I)=FUDGE*WDTP(I)
25999 WDTP(0)=WDTP(0)+WDTP(I)
26000 IF(MDME(IDC,1).GT.0) THEN
26001 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26002 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26003 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26004 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26008 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26009 C...u* excited quark.
26010 FAC=(SH/RTCM(41)**2)*SHR
26011 DO 440 I=1,MDCY(KC,3)
26013 IF(MDME(IDC,1).LT.0) GOTO 440
26014 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26015 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26016 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26020 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26022 ELSEIF(I.EQ.2) THEN
26023 C...u* -> gamma + u.
26024 QF=RTCM(43)/2D0+RTCM(44)/6D0
26025 WDTP(I)=FAC*AEM*QF**2/4D0
26027 ELSEIF(I.EQ.3) THEN
26029 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26030 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26031 & (1D0-RM1)**2*(2D0+RM1)
26033 ELSEIF(I.EQ.4) THEN
26035 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26036 & (1D0-RM1)**2*(2D0+RM1)
26037 IF(KFLR.GT.0) WID2=WIDS(24,2)
26038 IF(KFLR.LT.0) WID2=WIDS(24,3)
26040 WDTP(I)=FUDGE*WDTP(I)
26041 WDTP(0)=WDTP(0)+WDTP(I)
26042 IF(MDME(IDC,1).GT.0) THEN
26043 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26044 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26045 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26046 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26050 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26051 C...e* excited lepton.
26052 FAC=(SH/RTCM(41)**2)*SHR
26053 DO 450 I=1,MDCY(KC,3)
26055 IF(MDME(IDC,1).LT.0) GOTO 450
26056 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26057 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26058 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26061 C...e* -> gamma + e.
26062 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26063 WDTP(I)=FAC*AEM*QF**2/4D0
26065 ELSEIF(I.EQ.2) THEN
26067 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26068 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26069 & (1D0-RM1)**2*(2D0+RM1)
26071 ELSEIF(I.EQ.3) THEN
26073 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26074 & (1D0-RM1)**2*(2D0+RM1)
26075 IF(KFLR.GT.0) WID2=WIDS(24,3)
26076 IF(KFLR.LT.0) WID2=WIDS(24,2)
26078 WDTP(I)=FUDGE*WDTP(I)
26079 WDTP(0)=WDTP(0)+WDTP(I)
26080 IF(MDME(IDC,1).GT.0) THEN
26081 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26082 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26083 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26084 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26088 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26089 C...nu*_e excited neutrino.
26090 FAC=(SH/RTCM(41)**2)*SHR
26091 DO 460 I=1,MDCY(KC,3)
26093 IF(MDME(IDC,1).LT.0) GOTO 460
26094 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26095 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26096 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26099 C...nu*_e -> Z0 + nu*_e.
26100 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26101 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26102 & (1D0-RM1)**2*(2D0+RM1)
26104 ELSEIF(I.EQ.2) THEN
26105 C...nu*_e -> W+ + e.
26106 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26107 & (1D0-RM1)**2*(2D0+RM1)
26108 IF(KFLR.GT.0) WID2=WIDS(24,2)
26109 IF(KFLR.LT.0) WID2=WIDS(24,3)
26111 WDTP(I)=FUDGE*WDTP(I)
26112 WDTP(0)=WDTP(0)+WDTP(I)
26113 IF(MDME(IDC,1).GT.0) THEN
26114 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26115 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26116 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26117 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26121 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26122 C...G* (graviton resonance):
26123 FAC=(PARP(50)**2/PARU(1))*SHR
26124 DO 470 I=1,MDCY(KC,3)
26126 IF(MDME(IDC,1).LT.0) GOTO 470
26127 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26128 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26129 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26134 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26135 & PYHFTH(SH,SH*RM1,1D0)
26136 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26137 & (1D0+8D0*RM1/3D0)/320D0
26138 IF(I.EQ.6) WID2=WIDS(6,1)
26139 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
26140 ELSEIF(I.LE.16) THEN
26141 C...G* -> l+ + l-, nu + nubar
26143 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26144 & (1D0+8D0*RM1/3D0)/320D0
26145 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
26146 ELSEIF(I.EQ.17) THEN
26149 ELSEIF(I.EQ.18) THEN
26150 C...G* -> gamma + gamma.
26152 ELSEIF(I.EQ.19) THEN
26154 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26155 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
26157 ELSEIF(I.EQ.20) THEN
26159 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26160 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
26163 WDTP(I)=FUDGE*WDTP(I)
26164 WDTP(0)=WDTP(0)+WDTP(I)
26165 IF(MDME(IDC,1).GT.0) THEN
26166 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26167 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26168 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26169 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26173 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
26174 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26175 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
26176 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
26177 DO 480 I=1,MDCY(KC,3)
26179 IF(MDME(IDC,1).LT.0) GOTO 480
26180 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26181 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26182 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26183 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
26186 C...nu_lR -> l- qbar q'
26187 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26188 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26189 ELSEIF(I.LE.18) THEN
26190 C...nu_lR -> l+ q qbar'
26191 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
26192 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
26194 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26196 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
26198 X=(PM1+PM2+PM3)/SHR
26199 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
26201 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
26202 WDTP(I)=FAC*FCOF*FX*FY
26203 WDTP(I)=FUDGE*WDTP(I)
26204 WDTP(0)=WDTP(0)+WDTP(I)
26205 IF(MDME(IDC,1).GT.0) THEN
26206 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26207 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26208 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26209 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26213 ELSEIF(KFLA.EQ.9900023) THEN
26215 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
26216 DO 490 I=1,MDCY(KC,3)
26218 IF(MDME(IDC,1).LT.0) GOTO 490
26219 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26220 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26221 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
26225 C...Z_R0 -> q + qbar
26227 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
26228 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
26230 IF(I.EQ.6) WID2=WIDS(6,1)
26231 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
26232 C...Z_R0 -> l+ + l-
26236 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
26237 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
26242 ELSEIF(I.LE.15) THEN
26243 C...Z0 -> nu_R + nu_R, assumed Majorana.
26247 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
26250 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
26251 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
26252 WDTP(I)=FUDGE*WDTP(I)
26253 WDTP(0)=WDTP(0)+WDTP(I)
26254 IF(MDME(IDC,1).GT.0) THEN
26255 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26256 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26257 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26258 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26262 ELSEIF(KFLA.EQ.9900024) THEN
26264 FAC=(AEM/(24D0*XW))*SHR
26265 DO 500 I=1,MDCY(KC,3)
26267 IF(MDME(IDC,1).LT.0) GOTO 500
26268 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26269 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26270 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
26273 C...W_R+/- -> q + qbar'
26274 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26276 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26278 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
26280 ELSEIF(I.LE.12) THEN
26281 C...W_R+/- -> l+/- + nu_R
26284 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26285 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26286 WDTP(I)=FUDGE*WDTP(I)
26287 WDTP(0)=WDTP(0)+WDTP(I)
26288 IF(MDME(IDC,1).GT.0) THEN
26289 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26290 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26291 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26292 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26296 ELSEIF(KFLA.EQ.9900041) THEN
26298 FAC=(1D0/(8D0*PARU(1)))*SHR
26299 DO 510 I=1,MDCY(KC,3)
26301 IF(MDME(IDC,1).LT.0) GOTO 510
26302 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26303 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26304 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
26307 C...H_L++/-- -> l+/- + l'+/-
26308 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26309 & (IABS(KFDP(IDC,2))-9)/2)**2
26310 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26311 ELSEIF(I.EQ.7) THEN
26312 C...H_L++/-- -> W_L+/- + W_L+/-
26313 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
26314 & (3D0*RM1+0.25D0/RM1-1D0)
26315 WID2=WIDS(24,4+(1-KFLS)/2)
26318 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26319 WDTP(I)=FUDGE*WDTP(I)
26320 WDTP(0)=WDTP(0)+WDTP(I)
26321 IF(MDME(IDC,1).GT.0) THEN
26322 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26323 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26324 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26325 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26329 ELSEIF(KFLA.EQ.9900042) THEN
26331 FAC=(1D0/(8D0*PARU(1)))*SHR
26332 DO 520 I=1,MDCY(KC,3)
26334 IF(MDME(IDC,1).LT.0) GOTO 520
26335 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26336 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26337 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
26340 C...H_R++/-- -> l+/- + l'+/-
26341 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26342 & (IABS(KFDP(IDC,2))-9)/2)**2
26343 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26344 ELSEIF(I.EQ.7) THEN
26345 C...H_R++/-- -> W_R+/- + W_R+/-
26346 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
26347 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
26350 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26351 WDTP(I)=FUDGE*WDTP(I)
26352 WDTP(0)=WDTP(0)+WDTP(I)
26353 IF(MDME(IDC,1).GT.0) THEN
26354 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26355 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26356 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26357 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26361 ELSEIF(KFLA.EQ.KTECHN+115) THEN
26363 C...Need to update to alpha_rho
26364 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26365 FAC=(ALPRHT/12D0)*SHR
26366 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26370 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26372 XWRHT=1D0/(4D0*XW*(1D0-XW))
26373 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26374 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26375 DO 530 I=1,MDCY(KC,3)
26377 IF(MDME(IDC,1).LT.0) GOTO 530
26378 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26379 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26380 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
26382 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26385 FACPA=PCM**2+1.5D0*RM1
26388 C...a2_tc0 -> W+ + W-
26390 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
26391 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
26393 C...a2_tc0 -> W+ + pi_tc- + c.c.
26394 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
26395 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26397 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26399 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26401 ELSEIF(I.EQ.4) THEN
26402 C...a2_tc0 -> Z0 + pi_tc0'
26403 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
26404 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26406 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
26407 ELSEIF(I.GE.5.AND.I.LE.10) THEN
26408 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26409 FACPA=PCM**2*(1D0+RM1+RM2)
26413 C...a_T^0 -> gamma rho_T^0
26414 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26415 WID2=WIDS(PYCOMP(KTECHN+113),2)
26416 ELSEIF(I.EQ.6) THEN
26417 C...a_T^0 -> gamma omega_T
26418 VA2=1D0/RTCM(50)**4
26419 WID2=WIDS(PYCOMP(KTECHN+223),2)
26420 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
26421 C...a_T^0 -> W^+- rho_T^-+
26422 AA2=.25D0/XW/RTCM(51)**4
26424 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
26426 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
26428 ELSEIF(I.EQ.9) THEN
26429 C...a_T^0 -> Z^0 rho_T^0
26430 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26431 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
26432 ELSEIF(I.EQ.10) THEN
26433 C...a_T^0 -> Z^0 omega_T
26434 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
26435 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
26437 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26439 C...a2_tc0 -> f + fbar.
26444 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26448 IF(IA.GE.17) WID2=WIDS(IA,1)
26451 AI=SIGN(1D0,EI+0.1D0)
26455 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26456 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
26457 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26458 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
26460 WDTP(I)=FUDGE*WDTP(I)
26461 WDTP(0)=WDTP(0)+WDTP(I)
26462 IF(MDME(IDC,1).GT.0) THEN
26463 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26464 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26465 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26466 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26470 ELSEIF(KFLA.EQ.KTECHN+215) THEN
26472 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26473 FAC=(ALPRHT/12D0)*SHR
26477 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26479 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26480 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26481 DO 540 I=1,MDCY(KC,3)
26483 IF(MDME(IDC,1).LT.0) GOTO 540
26484 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26485 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26486 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
26488 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26497 C...a2_tc+ -> gamma + W+.
26499 AA2=RTCM(3)**2/RTCM(49)**2
26500 WID2=WIDS(24,ICHANN)
26501 C...a2_tc+ -> gamma + pi_tc+.
26502 ELSEIF(I.EQ.2) THEN
26503 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
26504 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
26505 C...a2_tc+ -> W+ + Z
26506 ELSEIF(I.EQ.3) THEN
26507 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
26508 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
26509 WID2=WIDS(24,ICHANN)*WIDS(23,2)
26510 C...a2_tc+ -> W+ + pi_tc0.
26511 ELSEIF(I.EQ.4) THEN
26512 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26513 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
26514 C...a2_tc+ -> W+ + pi_tc'0.
26515 ELSEIF(I.EQ.5) THEN
26516 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
26517 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
26518 C...a2_tc+ -> Z0 + pi_tc+.
26519 ELSEIF(I.EQ.6) THEN
26520 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
26522 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
26524 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26526 ELSEIF(I.LE.10) THEN
26527 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26528 FACPA=PCM**2*(1D0+RM1+RM2)
26531 C...a2_tc+ -> gamma + rho_tc+
26533 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26534 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
26535 C...a2_tc+ -> W+ + rho_T^0
26536 ELSEIF(I.EQ.8) THEN
26537 AA2=1D0/(4D0*XW)/RTCM(51)**4
26538 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
26539 C...a2_tc+ -> W+ + omega_T
26540 ELSEIF(I.EQ.9) THEN
26541 VA2=.25D0/XW/RTCM(50)**4
26542 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
26543 C...a2_tc+ -> Z^0 + rho_T^+
26544 ELSEIF(I.EQ.10) THEN
26545 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26546 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
26547 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
26549 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26551 C...a2_tc+ -> f + fbar'.
26555 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26557 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26558 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26559 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26561 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26562 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26563 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26568 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26570 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26573 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26574 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26576 WDTP(I)=FUDGE*WDTP(I)
26577 WDTP(0)=WDTP(0)+WDTP(I)
26578 IF(MDME(IDC,1).GT.0) THEN
26579 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26580 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26581 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26582 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26593 C***********************************************************************
26596 C...Calculates partial width and differential cross-section maxima
26597 C...of channels/processes not allowed on mass-shell, and selects
26598 C...masses in such channels/processes.
26600 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
26602 C...Double precision and integer declarations.
26603 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26604 IMPLICIT INTEGER(I-N)
26605 INTEGER PYK,PYCHGE,PYCOMP
26607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26609 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26610 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26612 COMMON/PYINT1/MINT(400),VINT(400)
26613 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26614 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
26615 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
26618 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
26619 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
26620 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
26623 C...Find if particles equal, maximum mass, matrix elements, etc.
26629 IF(KFD(1).EQ.KFD(2)) MEQL=1
26631 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
26632 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
26638 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
26641 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
26642 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
26643 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
26644 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
26645 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
26646 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
26649 C...Find where Breit-Wigners are required, else select discrete masses.
26651 KFCA=PYCOMP(KFD(I))
26653 PMD(I)=PMAS(KFCA,1)
26654 PGD(I)=PMAS(KFCA,2)
26659 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
26662 RMG(I)=(PMG(I)/PMMX)**2
26668 C...Find allowed mass range and Breit-Wigner parameters.
26670 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
26672 PMU(I)=PMMX-PARP(42)
26673 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26674 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26675 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
26677 IF(MLM.EQ.2) ILM=3-I
26678 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
26679 IF(MBW(3-I).EQ.0) THEN
26680 PMU(I)=PMMX-PMD(3-I)
26682 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
26684 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
26685 & MIN(PMU(I),CKIN(NOFF+2*ILM))
26686 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26687 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26688 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26689 IF(MBW(I).EQ.1) THEN
26690 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26691 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26692 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26695 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
26697 IF(MLM.EQ.2) ILM=3-I
26698 PML(I)=MAX(CKIN(48+I),PARP(42))
26699 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
26700 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26701 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26702 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26703 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26704 IF(MBW(I).EQ.1) THEN
26705 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26706 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26707 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26712 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
26714 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
26719 C...Calculation of partial width of resonance.
26720 IF(MOFSH.EQ.1) THEN
26722 C..If only one integration, pick that to be the inner.
26723 IF(MBW(1).EQ.0) THEN
26729 ELSEIF(MBW(2).EQ.0) THEN
26733 C...Start outer loop of integration.
26734 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26735 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26736 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26742 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26743 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
26744 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
26748 C...Start inner loop of integration.
26750 PMU1=MIN(PMU(1),PMMX-PM2)
26751 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
26752 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26753 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26754 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
26762 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
26763 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
26766 C...Evaluate function value - inner loop.
26767 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26768 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
26769 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
26770 & RM2**2+10D0*RM1*RM2)
26771 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
26774 C...Go to next position in inner loop.
26780 ELSEIF(NPT1.LE.8) THEN
26782 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
26784 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26785 INX1(NPT1)=INX1(ISH1)
26788 ELSEIF(NPT1.LT.100) THEN
26791 IF(ISH1.GT.NPT1) ISH1=2
26792 IF(ISH1.EQ.ISN1) GOTO 160
26793 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
26794 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
26796 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26797 INX1(NPT1)=INX1(ISH1)
26802 C...Calculate integral over inner loop.
26805 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
26806 & (XPT1(INX1(IPT1))-XPT1(IPT1))
26808 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
26809 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26810 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
26813 C...Go to next position in outer loop.
26819 ELSEIF(NPT2.LE.8) THEN
26821 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
26823 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26824 INX2(NPT2)=INX2(ISH2)
26827 ELSEIF(NPT2.LT.100) THEN
26830 IF(ISH2.GT.NPT2) ISH2=2
26831 IF(ISH2.EQ.ISN2) GOTO 200
26832 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
26833 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
26835 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26836 INX2(NPT2)=INX2(ISH2)
26841 C...Calculate integral over outer loop.
26844 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
26845 & (XPT2(INX2(IPT2))-XPT2(IPT2))
26847 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
26848 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
26853 C...Save result; second integration for user-selected mass range.
26854 IF(LOOP.EQ.1) WIDW=FSUM2
26856 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
26857 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
26864 C...Select two decay product masses of a resonance.
26865 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
26867 IF(MBW(I).EQ.0) GOTO 230
26868 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
26870 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
26871 RMG(I)=(PMG(I)/PMMX)**2
26873 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26874 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26876 C...Weight with matrix element (if none known, use beta factor).
26877 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26879 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26880 ELSEIF(MMED.EQ.2) THEN
26881 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26882 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26883 ELSEIF(MMED.EQ.3) THEN
26884 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26888 IF(WTBE.LT.PYR(0)) GOTO 220
26892 C...Find suitable set of masses for initialization of 2 -> 2 processes.
26893 ELSEIF(MOFSH.EQ.3) THEN
26894 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26895 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26897 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26899 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26903 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26904 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26905 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26910 C...Evaluate importance of excluded tails of Breit-Wigners.
26911 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26912 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26916 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26920 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26921 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26923 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26924 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26925 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26926 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26928 C...Pick one particle to be the lighter (if improves efficiency).
26929 ELSEIF(MOFSH.EQ.4) THEN
26930 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26931 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26932 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26934 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26936 IF(MBW(I).EQ.0) GOTO 270
26938 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26940 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26942 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26943 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26944 IF(RBR.LT.0.8D0) THEN
26945 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26946 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26947 ELSEIF(RBR.LT.0.9D0) THEN
26948 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26949 ELSEIF(RBR.LT.1.5D0) THEN
26950 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26952 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26953 & (PMV**2-PML(I)**2))))
26956 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26957 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26958 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26959 NGEN(0,1)=NGEN(0,1)+1
26960 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26970 C...Give weight for selected mass distribution.
26973 IF(MBW(I).EQ.0) GOTO 280
26975 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26977 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26978 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26979 & (PMD(I)*PGD(I))**2)/PARU(1)
26983 FI0=(ATV-ATL(I))/PARU(1)
26984 FI1=PMV**2-PML(I)**2
26985 FI2=2D0*LOG(PMV/PML(I))
26986 FI3=1D0/PML(I)**2-1D0/PMV**2
26987 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26988 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
26989 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
26992 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
26994 VINT(80)=VINT(80)*FI0
26996 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27002 C***********************************************************************
27005 C...Handles the possibility of colour reconnection in W+W- events,
27006 C...Based on the main scenarios of the Sjostrand and Khoze study:
27007 C...I, II, II', intermediate and instantaneous; plus one model
27008 C...along the lines of the Gustafson and Hakkinen: GH.
27009 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27010 C...is as if first resonance is W+ and second W-.
27012 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27014 C...Double precision and integer declarations.
27015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27016 IMPLICIT INTEGER(I-N)
27017 INTEGER PYK,PYCHGE,PYCOMP
27018 C...Parameter value; number of points in MC integration.
27019 PARAMETER (NPT=100)
27021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27025 COMMON/PYINT1/MINT(400),VINT(400)
27026 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27028 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27029 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27030 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27031 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27032 &TMC(20),IJOIN(100)
27034 C...Functions to give four-product and to do determinants.
27035 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)
27036 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27037 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27038 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27040 C...Only allow fraction of recoupling for GH, intermediate and
27042 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27043 IF(PYR(0).GT.PARP(120)) RETURN
27047 C...Common part for scenarios I, II, II', and GH.
27048 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27049 &MSTP(115).EQ.5) THEN
27051 C...Read out frequently-used parameters.
27055 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27057 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27064 C...Find range of decay products of the W's.
27065 C...Background: the W's are stored in IW1 and IW2.
27066 C...Their direct decay products in NSD1+1 through NSD1+4.
27067 C...Products after shower (if any) in NSD1+5 through NAFT1
27068 C...for first W and in NAFT1+1 through N for the second.
27069 IF(NAFT1.GT.NSD1+4) THEN
27076 IF(N.GT.NAFT1) THEN
27084 C...Rearrange parton shower products along strings.
27086 CALL PYPREP(NSD1+1)
27087 IF(MINT(51).NE.0) RETURN
27089 C...Find partons pointing back to W+ and W-; store them with quark
27090 C...end of string first.
27096 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27097 IF(IABS(K(I,2)).GE.22) GOTO 120
27098 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27099 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27109 IF(K(I,1).EQ.1) ISGP=0
27110 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27111 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27121 IF(K(I,1).EQ.1) ISGM=0
27125 C...Boost to W+W- rest frame (not strictly needed).
27127 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27129 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27130 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27131 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27133 C...Select decay vertices of W+ and W-.
27134 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27135 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27136 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27137 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27140 XP(J)=TP*P(IW1,J)/P(IW1,4)
27141 XM(J)=TM*P(IW2,J)/P(IW2,4)
27144 C...Begin scenario I specifics.
27145 IF(MSTP(115).EQ.1) THEN
27147 C...Reconstruct velocity and direction of W+ string pieces.
27149 IF(K(INP(IIP),2).LT.0) GOTO 170
27152 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27153 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27157 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
27158 DIRP(IIP,J)=V1(J)-V2(J)
27160 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
27162 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
27164 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
27168 C...Reconstruct velocity and direction of W- string pieces.
27170 IF(K(INM(IIM),2).LT.0) GOTO 200
27173 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27174 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27178 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
27179 DIRM(IIM,J)=V1(J)-V2(J)
27181 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
27183 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
27185 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
27189 C...Loop over number of space-time points.
27194 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27195 R=SQRT(-LOG(PYR(0)))
27197 X=BLOWR*RHAD*R*COS(PHI)
27198 Y=BLOWR*RHAD*R*SIN(PHI)
27199 R=SQRT(-LOG(PYR(0)))
27201 Z=BLOWR*RHAD*R*COS(PHI)
27202 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
27204 C...Reject impossible points. Weight for sample distribution.
27205 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
27206 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
27207 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
27209 C...Loop over W+ string pieces and find one with largest weight.
27217 IF(K(INP(IIP),2).LT.0) GOTO 220
27218 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
27219 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
27221 XB(J)=XD(J)+BEDG*BETP(IIP,J)
27223 XB(4)=BETP(IIP,4)*(XD(4)-BED)
27224 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27225 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
27226 & DIRP(IIP,3)*XB(3))**2
27227 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27229 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
27230 IF(WTP.GT.WTMAXP) THEN
27236 C...Loop over W- string pieces and find one with largest weight.
27244 IF(K(INM(IIM),2).LT.0) GOTO 240
27245 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
27246 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
27248 XB(J)=XD(J)+BEDG*BETM(IIM,J)
27250 XB(4)=BETM(IIM,4)*(XD(4)-BED)
27251 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27252 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
27253 & DIRM(IIM,3)*XB(3))**2
27254 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27256 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
27257 IF(WTM.GT.WTMAXM) THEN
27263 C...Result of integration.
27265 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
27266 WT=WTMAXP*WTMAXM/WTSMP
27274 RES=BLOWR**3*BLOWT*SUM/NPT
27276 C...Decide whether to reconnect and, if so, where.
27278 PREC=1D0-EXP(-FACT*RES)
27279 IF(PREC.GT.PYR(0)) THEN
27284 IF(RSUM.LE.0D0) GOTO 270
27290 C...Begin scenario II and II' specifics.
27291 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
27293 C...Loop through all string pieces, one from W+ and one from W-.
27297 IF(K(INP(IIP),2).LT.0) GOTO 340
27301 IF(K(INM(IIM),2).LT.0) GOTO 330
27305 C...Find endpoint velocity vectors.
27307 V1P(J)=P(I1P,J)/P(I1P,4)
27308 V2P(J)=P(I2P,J)/P(I2P,4)
27309 V1M(J)=P(I1M,J)/P(I1M,4)
27310 V2M(J)=P(I2M,J)/P(I2M,4)
27313 C...Define q matrix and find t.
27315 Q(1,J)=V2P(J)-V1P(J)
27316 Q(2,J)=-(V2M(J)-V1M(J))
27317 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
27318 Q(4,J)=V1P(J)-V1M(J)
27320 T=-DETER(1,2,3)/DETER(1,2,4)
27322 C...Find alpha and beta; i.e. coordinates of crossing point.
27325 S13=Q(3,1)+Q(4,1)*T
27328 S23=Q(3,2)+Q(4,2)*T
27329 DEN=S11*S22-S12*S21
27330 ALP=(S12*S23-S22*S13)/DEN
27331 BET=(S21*S13-S11*S23)/DEN
27333 C...Check if solution acceptable.
27335 IF(T.LT.GTMAX) IANSW=0
27336 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
27337 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
27339 C...Find point of crossing and check that not inconsistent.
27341 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
27342 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
27344 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
27345 & (XPP(3)-XMM(3))**2
27346 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
27347 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
27348 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
27350 C...Find string eigentimes at crossing.
27351 IF(IANSW.EQ.1) THEN
27352 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
27353 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
27354 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
27355 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
27361 C...Order crossings by time. End loop over crossings.
27362 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
27364 DO 310 I1=NCROSS,1,-1
27365 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
27385 C...Loop over crossings; find first (if any) acceptable one.
27387 IF(NCROSS.GE.1) THEN
27389 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
27390 IF(PNFRAG.GT.PYR(0)) THEN
27391 C...Scenario II: only compare with fragmentation time.
27392 IF(MSTP(115).EQ.2) THEN
27397 C...Scenario II': also require that string length decreases.
27405 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27406 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27407 IF(ELNEW.LT.ELOLD) THEN
27419 C...Begin scenario GH specifics.
27420 ELSEIF(MSTP(115).EQ.5) THEN
27422 C...Loop through all string pieces, one from W+ and one from W-.
27426 IF(K(INP(IIP),2).LT.0) GOTO 380
27430 IF(K(INM(IIM),2).LT.0) GOTO 370
27434 C...Look for largest decrease of (exponent of) Lambda measure.
27435 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27436 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27437 ELDIF=ELNEW/MAX(1D-10,ELOLD)
27438 IF(ELDIF.LT.ELMIN) THEN
27450 C...Common for scenarios I, II, II' and GH: reconnect strings.
27454 DO 390 IS=1,NNP+NNM
27458 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
27460 ELSEIF(IS.LE.IIP+NNM) THEN
27461 I=INM(IS-IIP-NNM+IIM)
27466 IF(K(I,2).LT.0) THEN
27467 CALL PYJOIN(NJOIN,IJOIN)
27472 C...Restore original event record if no reconnection.
27474 DO 400 I=NSD1+1,NOLD
27475 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
27476 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27477 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27486 C...Boost back system.
27487 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27488 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27489 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
27490 & BEWW(1),BEWW(2),BEWW(3))
27492 C...Common part for intermediate and instantaneous scenarios.
27493 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27496 C...Remove old shower products and reset showering ones.
27498 DO 420 I=NSD1+1,NSD1+4
27500 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27501 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27504 C...Identify quark-antiquark pairs.
27508 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
27511 C...Reconnect strings.
27514 CALL PYJOIN(2,IJOIN)
27517 CALL PYJOIN(2,IJOIN)
27519 C...Do new parton showers in intermediate scenario.
27520 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
27523 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
27524 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
27527 C...Do new parton showers in instantaneous scenario.
27528 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
27529 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
27530 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
27531 PPM=SQRT(MAX(0D0,PPM2))
27532 CALL PYSHOW(IQ1,IQ4,PPM)
27533 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
27534 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
27535 PPM=SQRT(MAX(0D0,PPM2))
27536 CALL PYSHOW(IQ3,IQ2,PPM)
27543 C***********************************************************************
27546 C...Checks generated variables against pre-set kinematical limits;
27547 C...also calculates limits on variables used in generation.
27549 SUBROUTINE PYKLIM(ILIM)
27551 C...Double precision and integer declarations.
27552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27553 IMPLICIT INTEGER(I-N)
27554 INTEGER PYK,PYCHGE,PYCOMP
27556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27560 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27562 COMMON/PYINT1/MINT(400),VINT(400)
27563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27567 C...Common kinematical expressions.
27571 IF(ISUB.EQ.96) GOTO 100
27575 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
27576 CKIN09=MAX(CKIN(9),CKIN(13))
27577 CKIN10=MIN(CKIN(10),CKIN(14))
27578 CKIN11=MAX(CKIN(11),CKIN(15))
27579 CKIN12=MIN(CKIN(12),CKIN(16))
27581 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
27582 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
27583 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
27584 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
27589 RM3=SQM3/(TAU*VINT(2))
27590 RM4=SQM4/(TAU*VINT(2))
27591 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27594 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
27595 &PTHMIN=MAX(CKIN(3),CKIN(5))
27598 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
27599 C...pre-set kinematical limits.
27604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27605 X1=SQRT(TAUE)*EXP(YST)
27606 X2=SQRT(TAUE)*EXP(-YST)
27608 IF(MINT(47).NE.1) THEN
27609 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
27610 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
27611 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
27612 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
27614 IF(MINT(45).NE.1) THEN
27615 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
27617 IF(MINT(46).NE.1) THEN
27618 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
27620 IF(MINT(45).EQ.2) THEN
27621 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27623 IF(MINT(46).EQ.2) THEN
27624 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
27627 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
27628 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
27629 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
27630 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
27631 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
27632 Y3=YST+0.5D0*LOG(EXPY3)
27633 Y4=YST+0.5D0*LOG(EXPY4)
27638 STH=SQRT(MAX(0D0,1D0-CTH**2))
27639 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
27640 & CTH)**2-4D0*RM3))
27641 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
27642 & CTH)**2-4D0*RM4))
27643 IF(STH.GE.1D-10) THEN
27644 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
27646 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
27648 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
27649 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
27650 ETALAR=MAX(ETA3,ETA4)
27651 ETASMA=MIN(ETA3,ETA4)
27653 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
27654 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
27655 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
27656 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
27658 RPTS=4D0*VINT(71)**2/SH
27659 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27660 RM34=MAX(1D-20,2D0*RM3*RM4)
27661 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27662 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27664 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
27665 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27666 IF(PTH.LT.PTHMIN) MINT(51)=1
27667 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
27668 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
27669 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
27670 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
27671 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
27672 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
27673 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
27674 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
27675 IF(THA.LT.CKIN(35)) MINT(51)=1
27676 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
27677 IF(UHA.LT.CKIN(37)) MINT(51)=1
27678 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
27680 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27681 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
27682 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
27685 C...Additional cuts on W2 (approximately) in DIS.
27686 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
27688 IF(IABS(MINT(12)).LT.20) XBJ=X1
27690 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
27691 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
27692 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
27695 ELSEIF(ILIM.EQ.1) THEN
27696 C...Calculate limits on tau
27697 C...0) due to definition
27700 C...1) due to limits on subsystem mass
27701 TAUMN1=CKIN(1)**2/VINT(2)
27703 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
27704 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
27705 TM3=SQRT(SQM3+PTHMIN**2)
27706 TM4=SQRT(SQM4+PTHMIN**2)
27708 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
27709 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
27711 C...3) due to limits on pT-hat and cos(theta-hat)
27712 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
27713 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
27715 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
27716 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
27717 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
27719 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
27720 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
27721 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
27722 C...4) due to limits on x1 and x2
27723 TAUMN4=CKIN(21)*CKIN(23)
27724 TAUMX4=CKIN(22)*CKIN(24)
27725 C...5) due to limits on xF
27727 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
27728 C...6) due to limits on that and uhat
27729 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
27731 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
27732 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
27734 C...Net effect of all separate limits.
27735 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
27736 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
27737 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27740 ELSEIF(MINT(47).EQ.5) THEN
27741 VINT(31)=MIN(VINT(31),1D0-2D-10)
27742 ELSEIF(MINT(47).GE.6) THEN
27743 VINT(31)=MIN(VINT(31),1D0-1D-10)
27745 IF(VINT(31).LE.VINT(11)) MINT(51)=1
27747 ELSEIF(ILIM.EQ.2) THEN
27748 C...Calculate limits on y*
27750 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27752 C...0) due to kinematics
27755 C...1) due to explicit limits
27758 C...2) due to limits on x1
27759 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
27760 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
27761 C...3) due to limits on x2
27762 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
27763 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
27764 C...4) due to limits on xF
27765 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
27766 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
27767 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
27768 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
27769 C...5) due to simultaneous limits on y-large and y-small
27770 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
27771 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
27772 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
27773 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
27774 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
27775 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
27776 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
27778 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
27779 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
27780 RZMX=BE34*MIN(CKIN(28),CTHLIM)
27781 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
27782 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
27783 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
27784 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
27785 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
27786 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
27788 C...Net effect of all separate limits.
27789 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
27790 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
27791 IF(MINT(47).EQ.1) THEN
27794 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27795 VINT(12)=(1D0-1D-9)*YSTMX0
27796 VINT(32)=(1D0+1D-9)*YSTMX0
27797 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27798 VINT(12)=-(1D0+1D-9)*YSTMX0
27799 VINT(32)=-(1D0-1D-9)*YSTMX0
27800 ELSEIF(MINT(47).EQ.5) THEN
27801 YSTEE=LOG((1D0-1D-10)/TAURT)
27802 VINT(12)=MAX(VINT(12),-YSTEE)
27803 VINT(32)=MIN(VINT(32),YSTEE)
27805 IF(VINT(32).LE.VINT(12)) MINT(51)=1
27807 ELSEIF(ILIM.EQ.3) THEN
27808 C...Calculate limits on cos(theta-hat)
27810 C...0) due to definition
27815 C...1) due to explicit limits
27816 CTNMN1=MIN(0D0,CKIN(27))
27817 CTNMX1=MIN(0D0,CKIN(28))
27818 CTPMN1=MAX(0D0,CKIN(27))
27819 CTPMX1=MAX(0D0,CKIN(28))
27820 C...2) due to limits on pT-hat
27821 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
27825 IF(CKIN(4).GE.0D0) THEN
27826 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
27827 & (BE34**2*TAU*VINT(2))))
27830 C...3) due to limits on y-large and y-small
27831 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
27832 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
27833 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
27834 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
27835 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
27836 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
27837 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
27838 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
27839 C...4) due to limits on that
27845 IF(CKIN(35).GT.0D0) THEN
27846 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
27847 IF(CTLIM.GT.0D0) THEN
27854 IF(CKIN(36).GT.0D0) THEN
27855 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
27856 IF(CTLIM.LT.0D0) THEN
27863 C...5) due to limits on uhat
27868 IF(CKIN(37).GT.0D0) THEN
27869 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
27870 IF(CTLIM.LT.0D0) THEN
27877 IF(CKIN(38).GT.0D0) THEN
27878 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27879 IF(CTLIM.GT.0D0) THEN
27887 C...Net effect of all separate limits.
27888 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27889 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27890 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27891 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27892 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27894 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
27895 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
27897 ELSEIF(ILIM.EQ.4) THEN
27898 C...Calculate limits on tau'
27899 C...0) due to kinematics
27901 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27902 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27903 TAPMN0=(SQRT(TAU)+PQRAT)**2
27906 C...1) due to explicit limits
27907 TAPMN1=CKIN(31)**2/VINT(2)
27909 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27911 C...Net effect of all separate limits.
27912 VINT(16)=MAX(TAPMN0,TAPMN1)
27913 VINT(36)=MIN(TAPMX0,TAPMX1)
27914 IF(MINT(47).EQ.1) THEN
27917 ELSEIF(MINT(47).EQ.5) THEN
27918 VINT(36)=MIN(VINT(36),1D0-2D-10)
27919 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27920 VINT(36)=MIN(VINT(36),1D0-1D-10)
27922 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27927 C...Special case for low-pT and multiple interactions:
27928 C...effective kinematical limits for tau, y*, cos(theta-hat).
27929 100 IF(ILIM.EQ.0) THEN
27930 ELSEIF(ILIM.EQ.1) THEN
27931 IF(MSTP(82).LE.1) THEN
27932 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27935 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27938 ELSEIF(ILIM.EQ.2) THEN
27939 VINT(12)=0.5D0*LOG(VINT(21))
27941 ELSEIF(ILIM.EQ.3) THEN
27942 IF(MSTP(82).LE.1) THEN
27943 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27944 & (VINT(21)*VINT(2))
27946 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27947 & (VINT(21)*VINT(2))
27949 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27958 C*********************************************************************
27961 C...Maps a uniform distribution into a distribution of a kinematical
27962 C...variable according to one of the possibilities allowed. It is
27963 C...assumed that kinematical limits have been set by a PYKLIM call.
27965 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27967 C...Double precision and integer declarations.
27968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27969 IMPLICIT INTEGER(I-N)
27970 INTEGER PYK,PYCHGE,PYCOMP
27972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27974 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27975 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27976 COMMON/PYINT1/MINT(400),VINT(400)
27977 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27978 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
27980 C...Convert VVAR to tau variable.
27986 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
27989 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
27992 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
27996 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27998 ELSEIF(MVAR.EQ.1) THEN
27999 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28000 ELSEIF(MVAR.EQ.2) THEN
28001 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28002 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28003 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28004 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28005 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28006 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28007 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28008 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28009 ELSEIF(MINT(47).EQ.5) THEN
28010 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28011 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28012 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28014 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28015 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28016 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28018 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28020 C...Convert VVAR to y* variable.
28021 ELSEIF(IVAR.EQ.2) THEN
28025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28026 IF(MINT(47).EQ.1) THEN
28028 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28029 YST=-0.5D0*LOG(TAUE)
28030 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28031 YST=0.5D0*LOG(TAUE)
28032 ELSEIF(MVAR.EQ.1) THEN
28033 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28034 ELSEIF(MVAR.EQ.2) THEN
28035 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28036 ELSEIF(MVAR.EQ.3) THEN
28037 AUPP=ATAN(EXP(YSTMAX))
28038 ALOW=ATAN(EXP(YSTMIN))
28039 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28040 ELSEIF(MVAR.EQ.4) THEN
28041 YST0=-0.5D0*LOG(TAUE)
28042 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28043 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28044 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28046 YST0=-0.5D0*LOG(TAUE)
28047 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28048 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28049 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28051 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28053 C...Convert VVAR to cos(theta-hat) variable.
28054 ELSEIF(IVAR.EQ.3) THEN
28055 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28057 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28058 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28066 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28067 VCTN=VVAR*(ANEG+APOS)/ANEG
28068 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28070 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28071 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28073 ELSEIF(MVAR.EQ.2) THEN
28074 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28075 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28076 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28077 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28078 ANEG=LOG(RMNMIN/RMNMAX)
28079 APOS=LOG(RMPMIN/RMPMAX)
28080 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28081 VCTN=VVAR*(ANEG+APOS)/ANEG
28082 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28084 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28085 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28087 ELSEIF(MVAR.EQ.3) THEN
28088 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28089 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28090 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28091 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28092 ANEG=LOG(RMNMAX/RMNMIN)
28093 APOS=LOG(RMPMAX/RMPMIN)
28094 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28095 VCTN=VVAR*(ANEG+APOS)/ANEG
28096 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28098 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28099 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28101 ELSEIF(MVAR.EQ.4) THEN
28102 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28103 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28104 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28105 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28106 ANEG=1D0/RMNMAX-1D0/RMNMIN
28107 APOS=1D0/RMPMAX-1D0/RMPMIN
28108 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28109 VCTN=VVAR*(ANEG+APOS)/ANEG
28110 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28112 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28113 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28115 ELSEIF(MVAR.EQ.5) THEN
28116 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28117 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28118 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28119 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28120 ANEG=1D0/RMNMIN-1D0/RMNMAX
28121 APOS=1D0/RMPMIN-1D0/RMPMAX
28122 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28123 VCTN=VVAR*(ANEG+APOS)/ANEG
28124 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28126 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28127 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28130 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28131 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28134 C...Convert VVAR to tau' variable.
28135 ELSEIF(IVAR.EQ.4) THEN
28139 IF(MINT(47).EQ.1) THEN
28141 ELSEIF(MVAR.EQ.1) THEN
28142 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
28143 ELSEIF(MVAR.EQ.2) THEN
28144 AUPP=(1D0-TAU/TAUPMX)**4
28145 ALOW=(1D0-TAU/TAUPMN)**4
28146 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
28147 ELSEIF(MINT(47).EQ.5) THEN
28148 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
28149 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
28150 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28152 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
28153 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
28154 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28156 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
28158 C...Selection of extra variables needed in 2 -> 3 process:
28159 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28160 C...Since no options are available, the functions of PYKLIM
28161 C...and PYKMAP are joint for these choices.
28162 ELSEIF(IVAR.EQ.5) THEN
28164 C...Read out total energy and particle masses.
28167 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
28168 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
28170 SHP=VINT(26)*VINT(2)
28174 PM3=SQRT(VINT(21))*VINT(1)
28175 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
28182 C...Specify coefficients of pT choice; upper and lower limits.
28183 IF(MPTPK.EQ.1) THEN
28191 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
28193 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
28195 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
28197 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
28200 C...Select transverse momenta according to
28201 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28204 IF(HMX.LT.1.0001D0*HMN) THEN
28210 IF(RPT.LT.HWT1) THEN
28211 PTS1=PTSMN1+PYR(0)*HDE
28212 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28213 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
28215 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
28217 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
28218 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
28221 IF(HMX.LT.1.0001D0*HMN) THEN
28227 IF(RPT.LT.HWT1) THEN
28228 PTS2=PTSMN2+PYR(0)*HDE
28229 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28230 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
28232 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
28234 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
28235 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
28237 C...Select azimuthal angles and check pT choice.
28238 PHI1=PARU(2)*PYR(0)
28239 PHI2=PARU(2)*PYR(0)
28241 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
28242 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
28243 & CKIN(56)**2)) THEN
28248 C...Calculate transverse masses and check phase space not closed.
28255 PM12=(PMT1+PMT2)**2
28256 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
28261 C...Select rapidity for particle 3 and check phase space not closed.
28262 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
28263 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
28264 IF(Y3MAX.LT.1D-6) THEN
28268 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
28272 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
28275 PMS12=PE12**2-PZ12**2
28276 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
28277 IF(SQL12.LT.1D-6*SHP) THEN
28281 PMM1=PMS12+PMS1-PMS2
28282 PMM2=PMS12+PMS2-PMS1
28283 TFAC=-SHPR/(2D0*PMS12)
28284 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
28285 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
28286 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
28287 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
28289 C...Construct relative mirror weights and make choice.
28290 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
28294 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
28295 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
28297 WTP=WTPU/(WTPU+WTNU)
28298 WTN=WTNU/(WTPU+WTNU)
28300 IF(WTN.GT.PYR(0)) EPS=-1D0
28302 C...Store result of variable choice and associated weights.
28312 IF(EPS.GT.0D0) THEN
28321 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
28322 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
28323 VINT(219)=0.5D0*(PMS12-PTS3)
28330 C***********************************************************************
28333 C...Differential matrix elements for all included subprocesses
28334 C...Note that what is coded is (disregarding the COMFAC factor)
28335 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
28336 C...when d(sigma-hat) is given in the zero-width limit, the delta
28337 C...function in tau is replaced by a (modified) Breit-Wigner:
28338 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
28339 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
28340 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
28341 C...i.e., dimensionless quantities
28342 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
28343 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
28344 C...(2pi)^4 delta^4(P - sum p_i)
28345 C...COMFAC contains the factor pi/s (or equivalent) and
28346 C...the conversion factor from GeV^-2 to mb
28348 SUBROUTINE PYSIGH(NCHN,SIGS)
28350 C...Double precision and integer declarations
28351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28352 IMPLICIT INTEGER(I-N)
28353 INTEGER PYK,PYCHGE,PYCOMP
28354 C...Parameter statement to help give large particle numbers.
28355 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28356 &KEXCIT=4000000,KDIMEN=5000000)
28358 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28359 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28360 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28361 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28362 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28363 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28364 COMMON/PYINT1/MINT(400),VINT(400)
28365 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28366 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28367 COMMON/PYINT4/MWID(500),WIDS(500,5)
28368 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28369 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28370 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28371 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28372 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
28373 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
28374 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28375 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28376 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28377 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28378 COMMON/PYTCCO/COEFX(194:380,2)
28379 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28380 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
28381 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
28382 C...Local arrays and complex variables
28383 DIMENSION XPQ(-25:25)
28385 C...Map of processes onto which routine to call
28386 C...in order to evaluate cross section:
28387 C...0 = not implemented;
28388 C...1 = standard QCD (including photons);
28389 C...2 = heavy flavours;
28391 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
28393 C...6 = Technicolor;
28394 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28395 DIMENSION MAPPR(500)
28396 DATA (MAPPR(I),I=1,180)/
28397 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
28398 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
28399 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
28400 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
28401 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28402 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
28403 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
28404 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
28405 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28406 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
28407 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
28408 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
28409 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
28410 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
28411 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
28412 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
28413 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
28414 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
28415 DATA (MAPPR(I),I=181,500)/
28416 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
28417 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
28419 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28421 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
28422 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
28423 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
28424 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
28425 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
28426 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
28428 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28429 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28431 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28432 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28435 C...Reset number of channels and cross-section
28439 C...Read process to consider.
28444 C...Read kinematical variables and limits
28462 C...Derive kinematical quantities
28464 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28465 X(1)=SQRT(TAUE)*EXP(YST)
28466 X(2)=SQRT(TAUE)*EXP(-YST)
28467 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
28468 IF(X(1).GT.1D0-1D-7) RETURN
28469 ELSEIF(MINT(45).EQ.3) THEN
28470 X(1)=MIN(1D0-1.1D-10,X(1))
28472 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
28473 IF(X(2).GT.1D0-1D-7) RETURN
28474 ELSEIF(MINT(46).EQ.3) THEN
28475 X(2)=MIN(1D0-1.1D-10,X(2))
28477 SH=MAX(1D0,TAU*VINT(2))
28482 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28483 RPTS=4D0*VINT(71)**2/SH
28484 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28485 RM34=MAX(1D-20,2D0*RM3*RM4)
28487 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
28488 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
28489 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28490 IF(ISTSB.EQ.0) THEN
28492 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28493 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
28495 C...Kinematics with incoming masses tricky: now depends on how
28496 C...subprocess has been set up w.r.t. order of incoming partons.
28498 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
28500 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
28501 IF(ISUB.EQ.35) THEN
28505 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28506 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
28507 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
28509 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
28511 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
28518 C...Choice of Q2 scale for hard process (e.g. alpha_s).
28519 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
28521 ELSEIF(ISTSB.EQ.8) THEN
28522 IF(MINT(107).EQ.4) Q2=VINT(307)
28523 IF(MINT(108).EQ.4) Q2=VINT(308)
28524 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
28526 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
28528 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
28529 IF(MSTP(32).EQ.1) THEN
28530 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
28531 ELSEIF(MSTP(32).EQ.2) THEN
28532 Q2=SQPTH+0.5D0*(SQM3+SQM4)
28533 ELSEIF(MSTP(32).EQ.3) THEN
28535 ELSEIF(MSTP(32).EQ.4) THEN
28537 ELSEIF(MSTP(32).EQ.5) THEN
28539 ELSEIF(MSTP(32).EQ.6) THEN
28541 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
28543 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
28544 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
28545 & (SQPTH+0.5D0*(SQM3+SQM4))
28546 ELSEIF(MSTP(32).EQ.7) THEN
28547 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
28548 ELSEIF(MSTP(32).EQ.8) THEN
28549 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
28550 ELSEIF(MSTP(32).EQ.9) THEN
28551 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
28552 ELSEIF(MSTP(32).EQ.10) THEN
28555 ELSEIF(MSTP(32).EQ.11) THEN
28556 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
28557 ELSEIF(MSTP(32).EQ.12) THEN
28560 ELSEIF(MSTP(32).EQ.13) THEN
28563 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
28564 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
28565 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
28568 C...Choice of Q2 scale for parton densities.
28571 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
28572 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
28575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28577 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
28578 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
28579 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
28580 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
28581 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
28582 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
28583 IF(MSTP(39).EQ.2) Q2SF=
28584 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
28585 IF(MSTP(39).EQ.3) Q2SF=SH
28586 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
28587 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
28589 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
28590 IF(MSTP(39).EQ.7) Q2SF=
28591 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
28592 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
28596 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
28600 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
28601 IF(MSTP(69).GE.2) Q2SF=VINT(2)
28603 C...Identify to which class(es) subprocess belongs
28607 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
28608 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
28609 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
28610 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
28611 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
28612 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
28613 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
28614 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
28615 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
28616 IF (ISTSB.EQ.9) ISQCD=1
28617 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
28618 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
28619 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
28620 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
28621 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
28622 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
28623 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
28624 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
28625 C...WBF is special case of ISJETS
28626 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
28627 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
28628 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
28629 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
28630 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
28631 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
28632 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
28633 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
28634 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
28635 C...Some processes with photons also belong here.
28636 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
28637 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
28638 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
28639 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
28640 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
28641 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
28643 C...Choice of Q2 scale for parton-shower activity.
28644 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
28645 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
28647 IF(MINT(43).EQ.3) XBJ=X(1)
28648 IF(MSTP(22).EQ.1) THEN
28650 ELSEIF(MSTP(22).EQ.2) THEN
28651 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
28652 ELSEIF(MSTP(22).EQ.3) THEN
28653 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
28655 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
28658 C...For multiple interactions, start from scale defined above
28659 C...For all other QCD or "+jets"-type events, start shower from pThard.
28660 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
28661 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
28662 C...Max shower scale = s for ME corrected processes.
28663 C...(pT-ordering: max pT2 is s/4)
28665 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28666 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
28667 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
28668 C...(pT-ordering: max pT2 is s/4)
28670 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28672 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
28674 C...Elastic and diffractive events not associated with scales so set 0.
28675 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
28680 C...Store derived kinematical quantities
28687 IF(ISTSB.NE.8) VINT(48)=SQPTH
28688 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
28689 VINT(50)=TAUP*VINT(2)
28690 VINT(49)=SQRT(MAX(0D0,VINT(50)))
28694 VINT(53)=SQRT(Q2SF)
28696 VINT(55)=SQRT(Q2PS)
28698 C...Set starting scale for multiple interactions
28699 IF (ISUBSV.EQ.95) THEN
28701 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
28702 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
28703 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
28704 & ISUBSV.NE.96)) THEN
28705 C...All accessible phase space allowed.
28706 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
28708 C...Scale of hard process sets limit.
28709 C...2 -> 1. Limit is tau = x1*x2.
28710 C...2 -> 2. Limit is XT2 for hard process + FS masses.
28711 C...2 -> n > 2. Limit is tau' = tau of outer process.
28713 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
28715 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
28716 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
28718 VINT(62)=0.25D0*XT2GMX*VINT(2)
28719 VINT(61)=SQRT(MAX(0D0,VINT(62)))
28721 C...Calculate parton distributions
28722 IF(ISTSB.LE.0) GOTO 160
28723 IF(MINT(47).GE.2) THEN
28724 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
28726 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
28727 IF(ISUB.EQ.99) THEN
28728 IF(MINT(140+I).EQ.0) THEN
28729 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
28731 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
28736 MINT(105)=MINT(102+I)
28737 MINT(109)=MINT(106+I)
28738 VINT(120)=VINT(2+I)
28740 C.... Store side in MINT(124)
28743 IF(MSTP(57).LE.1) THEN
28744 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
28746 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
28748 C...Safety margin against heavy flavour very close to threshold,
28749 C...e.g. caused by mismatch in c and b masses.
28750 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
28754 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
28759 XSFX(I,KFL)=XPQ(KFL)
28764 C...Calculate alpha_em, alpha_strong and K-factor
28767 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
28768 &1D0-(PMAS(24,1)/PMAS(23,1))**2
28770 XWC=1D0/(16D0*XW*XW1)
28772 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
28773 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
28776 IF(MSTP(33).EQ.1) THEN
28778 ELSEIF(MSTP(33).EQ.2) THEN
28780 FACA=PARP(32)/PARP(31)
28781 ELSEIF(MSTP(33).EQ.3) THEN
28783 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
28784 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
28791 C...Set flags for allowed reacting partons/leptons
28796 IF(MINT(44+I).EQ.1) THEN
28797 KFAC(I,MINT(10+I))=1
28798 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
28799 KFAC(I,MINT(10+I))=1
28805 KFAC(I,J)=KFIN(I,J)
28806 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
28807 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
28812 C...Lower and upper limit for fermion flavour loops
28818 IF(KFAC(1,-J).EQ.1) MMIN1=-J
28819 IF(KFAC(1,J).EQ.1) MMAX1=J
28820 IF(KFAC(2,-J).EQ.1) MMIN2=-J
28821 IF(KFAC(2,J).EQ.1) MMAX2=J
28823 MMINA=MIN(MMIN1,MMIN2)
28824 MMAXA=MAX(MMAX1,MMAX2)
28826 C...Common resonance mass and width combinations
28829 GMMZ=PMAS(23,1)*PMAS(23,2)
28830 GMMW=PMAS(24,1)*PMAS(24,2)
28832 C...Polarization factors...implemented so far for W+W-(25)
28833 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
28834 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
28835 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
28836 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
28838 C...Phase space integral in tau
28839 COMFAC=PARU(1)*PARU(5)/VINT(2)
28840 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
28841 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
28842 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
28843 ATAU1=LOG(TAUMAX/TAUMIN)
28844 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
28845 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
28846 IF(MINT(72).GE.1) THEN
28849 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
28851 IF(ATAUD.GT.1D-10) H1=H1+
28852 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
28853 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
28855 IF(ATAUD.GT.1D-10) H1=H1+
28856 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
28858 IF(MINT(72).GE.2) THEN
28861 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
28863 IF(ATAUD.GT.1D-10) H1=H1+
28864 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
28865 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
28867 IF(ATAUD.GT.1D-10) H1=H1+
28868 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
28870 IF(MINT(72).EQ.3) THEN
28873 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
28875 IF(ATAUD.GT.1D-10) H1=H1+
28876 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
28877 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
28879 IF(ATAUD.GT.1D-10) H1=H1+
28880 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
28882 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28883 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
28884 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28885 & MAX(2D-10,1D0-TAU)
28886 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28887 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
28888 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28889 & MAX(1D-10,1D0-TAU)
28891 COMFAC=COMFAC*ATAU1/(TAU*H1)
28894 C...Phase space integral in y*
28895 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
28897 AYST0=YSTMAX-YSTMIN
28898 IF(AYST0.LT.1D-10) THEN
28901 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28903 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28904 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28905 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28906 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28907 IF(MINT(45).EQ.3) THEN
28908 YST0=-0.5D0*LOG(TAUE)
28909 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28910 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28911 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28912 & MAX(1D-10,1D0-EXP(YST-YST0))
28914 IF(MINT(46).EQ.3) THEN
28915 YST0=-0.5D0*LOG(TAUE)
28916 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28917 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28918 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28919 & MAX(1D-10,1D0-EXP(-YST-YST0))
28921 COMFAC=COMFAC*AYST0/H2
28925 C...2 -> 1 processes: reduction in angular part of phase space integral
28926 C...for case of decaying resonance
28927 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28928 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28929 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28930 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28931 & KFPR(ISUB,1).EQ.39) THEN
28932 COMFAC=COMFAC*0.5D0*ACTH0
28934 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28935 & CTPMAX**3-CTPMIN**3)
28939 C...2 -> 2 processes: angular part of phase space integral
28940 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28941 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28942 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28943 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28944 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28945 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28946 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28947 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28948 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28949 H3=COEF(ISUBSV,13)+
28950 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28951 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28952 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28953 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28954 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28956 C...2 -> 2 processes: take into account final state Breit-Wigners
28957 COMFAC=COMFAC*VINT(80)
28960 C...2 -> 3, 4 processes: phace space integral in tau'
28961 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28962 ATAUP1=LOG(TAUPMX/TAUPMN)
28963 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28964 H4=COEF(ISUBSV,18)+
28965 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28966 IF(MINT(47).EQ.5) THEN
28967 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28968 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28969 ELSEIF(MINT(47).GE.6) THEN
28970 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28971 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28973 COMFAC=COMFAC*ATAUP1/H4
28976 C...2 -> 3, 4 processes: effective W/Z parton distributions
28977 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28978 IF(1D0-TAU/TAUP.GT.1D-4) THEN
28979 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
28981 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
28986 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
28987 IF(ISTSB.EQ.5) THEN
28988 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
28989 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
28992 C...Phase space integral for low-pT and multiple interactions
28993 IF(ISTSB.EQ.9) THEN
28994 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
28995 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
28996 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
28997 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
28998 COMFAC=COMFAC*ATAU1/H1
28999 AYST0=YSTMAX-YSTMIN
29000 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29001 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29002 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29003 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29004 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29005 COMFAC=COMFAC*AYST0/H2
29006 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29007 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29008 C...introduced to make cross-section finite for xT2 -> 0
29009 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29013 C...Real gamma + gamma: include factor 2 when different nature
29014 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29015 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29017 C...Extra factors to include the effects of
29018 C...longitudinal resolved photons (but not direct or DIS ones).
29020 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29021 & MINT(106+ISDE).LE.3) THEN
29024 IF(MSTP(16).EQ.0) THEN
29025 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29026 & XY=VINT(304+ISDE)
29028 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29029 & XY=VINT(308+ISDE)
29031 Q2GA=VINT(306+ISDE)
29032 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29033 & Q2GA.GT.0D0) THEN
29035 IF(MSTP(17).EQ.1) THEN
29036 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29037 ELSEIF(MSTP(17).EQ.2) THEN
29038 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29039 ELSEIF(MSTP(17).EQ.3) THEN
29040 PMVIRT=PMAS(PYCOMP(113),1)
29041 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29042 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29043 PMVIRT=PMAS(PYCOMP(113),1)
29044 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29045 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29046 PMVIRT=PMAS(PYCOMP(113),1)
29047 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29048 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29049 PMVSMN=4D0*PARP(15)**2
29050 PMVSMX=4D0*VINT(154)**2
29051 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29052 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29053 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29054 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29055 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29056 PMVIRT=PMAS(PYCOMP(113),1)
29057 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29058 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29059 PMVIRT=PMAS(PYCOMP(113),1)
29060 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29061 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29062 PMVSMN=4D0*PARP(15)**2
29063 PMVSMX=4D0*VINT(154)**2
29064 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29065 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29066 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29069 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29070 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29071 & (1D0-2D0*BEAMAS**2/Q2GA))
29072 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29077 COMFAC=COMFAC*VINT(314+ISDE)
29080 C...Evaluate cross sections - done in separate routines by kind
29081 C...of physics, to keep PYSIGH of sensible size.
29083 C...Standard QCD (including photons).
29084 CALL PYSGQC(NCHN,SIGS)
29085 ELSEIF(MAP.EQ.2) THEN
29086 C...Heavy flavours.
29087 CALL PYSGHF(NCHN,SIGS)
29088 ELSEIF(MAP.EQ.3) THEN
29090 CALL PYSGWZ(NCHN,SIGS)
29091 ELSEIF(MAP.EQ.4) THEN
29092 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29093 CALL PYSGHG(NCHN,SIGS)
29094 ELSEIF(MAP.EQ.5) THEN
29096 CALL PYSGSU(NCHN,SIGS)
29097 ELSEIF(MAP.EQ.6) THEN
29099 CALL PYSGTC(NCHN,SIGS)
29100 ELSEIF(MAP.EQ.7) THEN
29101 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29102 CALL PYSGEX(NCHN,SIGS)
29105 C...Multiply with parton distributions
29106 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29108 IF(MINT(45).GE.2) THEN
29110 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29112 IF(MINT(46).GE.2) THEN
29114 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29116 SIGS=SIGS+SIGH(ICHN)
29123 C*********************************************************************
29126 C...Subprocess cross sections for QCD processes,
29127 C...including photons.
29128 C...Auxiliary to PYSIGH.
29130 SUBROUTINE PYSGQC(NCHN,SIGS)
29132 C...Double precision and integer declarations
29133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29134 IMPLICIT INTEGER(I-N)
29135 INTEGER PYK,PYCHGE,PYCOMP
29136 C...Parameter statement to help give large particle numbers.
29137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29138 &KEXCIT=4000000,KDIMEN=5000000)
29140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29142 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29144 COMMON/PYINT1/MINT(400),VINT(400)
29145 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29146 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29147 COMMON/PYINT4/MWID(500),WIDS(500,5)
29148 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29149 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29150 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29151 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29152 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29153 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
29154 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
29156 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29158 C...Differential cross section expressions.
29160 IF(ISUB.LE.20) THEN
29161 IF(ISUB.EQ.10) THEN
29162 C...f + f' -> f + f' (gamma/Z/W exchange)
29163 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
29164 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
29165 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
29166 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
29167 DO 110 I=MMIN1,MMAX1
29168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
29170 DO 100 J=MMIN2,MMAX2
29171 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
29173 C...Electroweak couplings
29174 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
29175 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
29177 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
29178 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
29181 C...gamma/Z exchange, only gamma exchange, or only Z exchange
29182 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
29183 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
29184 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
29185 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
29186 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
29187 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29188 ELSEIF(MSTP(21).EQ.2) THEN
29189 FACNCF=FACGGF*EI**2*EJ**2
29191 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
29192 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29194 C...Extrafactor 2 for only one incoming neutrino spin state.
29195 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
29196 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
29204 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
29205 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
29206 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
29207 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
29208 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
29218 ELSEIF(ISUB.EQ.11) THEN
29219 C...f + f' -> f + f' (g exchange)
29220 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29221 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29222 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29223 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
29224 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
29225 DO 130 I=MMIN1,MMAX1
29227 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
29228 DO 120 J=MMIN2,MMAX2
29230 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
29236 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29238 SIGH(NCHN)=0.5D0*SIGH(NCHN)
29243 SIGH(NCHN)=0.5D0*FACQQ2
29248 ELSEIF(ISUB.EQ.12) THEN
29249 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
29250 CALL PYWIDT(21,SH,WDTP,WDTE)
29251 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29252 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
29253 DO 140 I=MMINA,MMAXA
29254 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29255 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
29263 ELSEIF(ISUB.EQ.13) THEN
29264 C...f + fbar -> g + g (q + qbar -> g + g only)
29265 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29267 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29269 DO 150 I=MMINA,MMAXA
29270 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29271 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
29276 SIGH(NCHN)=0.5D0*FACGG1
29281 SIGH(NCHN)=0.5D0*FACGG2
29284 ELSEIF(ISUB.EQ.14) THEN
29285 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
29286 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
29287 DO 160 I=MMINA,MMAXA
29288 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29289 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
29290 EI=KCHG(IABS(I),1)/3D0
29295 SIGH(NCHN)=FACGG*EI**2
29298 ELSEIF(ISUB.EQ.18) THEN
29299 C...f + fbar -> gamma + gamma
29300 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
29301 DO 170 I=MMINA,MMAXA
29302 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
29303 EI=KCHG(IABS(I),1)/3D0
29305 IF(IABS(I).LE.10) FCOI=FACA/3D0
29310 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
29314 ELSEIF(ISUB.LE.40) THEN
29315 IF(ISUB.EQ.28) THEN
29316 C...f + g -> f + g (q + g -> q + g only)
29317 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29319 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29321 DO 190 I=MMINA,MMAXA
29322 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
29324 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
29325 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
29328 ISIG(NCHN,3-ISDE)=21
29333 ISIG(NCHN,3-ISDE)=21
29339 ELSEIF(ISUB.EQ.29) THEN
29340 C...f + g -> f + gamma (q + g -> q + gamma only)
29341 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
29342 DO 210 I=MMINA,MMAXA
29343 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
29344 EI=KCHG(IABS(I),1)/3D0
29347 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
29348 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
29351 ISIG(NCHN,3-ISDE)=21
29357 ELSEIF(ISUB.EQ.33) THEN
29358 C...f + gamma -> f + g (q + gamma -> q + g only)
29359 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
29360 DO 230 I=MMINA,MMAXA
29361 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
29362 EI=KCHG(IABS(I),1)/3D0
29365 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
29366 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
29369 ISIG(NCHN,3-ISDE)=22
29375 ELSEIF(ISUB.EQ.34) THEN
29376 C...f + gamma -> f + gamma
29377 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
29378 DO 250 I=MMINA,MMAXA
29379 IF(I.EQ.0) GOTO 250
29380 EI=KCHG(IABS(I),1)/3D0
29383 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
29384 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
29387 ISIG(NCHN,3-ISDE)=22
29394 ELSEIF(ISUB.LE.80) THEN
29395 IF(ISUB.EQ.53) THEN
29396 C...g + g -> f + fbar (g + g -> q + qbar only)
29397 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
29399 C...Begin by d, u, s flavours.
29401 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29402 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29403 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29404 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29405 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29406 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29407 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29408 & UH2/SH2)*FLAVWT*FACA
29409 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29410 & TH2/SH2)*FLAVWT*FACA
29421 C...Next c and b flavours: modified that and uhat for fixed
29422 C...cos(theta-hat).
29424 SQMAVG=PMAS(IFL,1)**2
29425 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29426 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29427 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29428 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29429 THUHQ=THQ*UHQ-SQMAVG*SH
29430 IF(MSTP(34).EQ.0) THEN
29431 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29432 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29434 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29435 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29436 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29437 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29439 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29440 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29444 ISIG(NCHN,3)=1+2*(IFL-3)
29449 ISIG(NCHN,3)=2+2*(IFL-3)
29455 ELSEIF(ISUB.EQ.54) THEN
29456 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
29457 CALL PYWIDT(21,SH,WDTP,WDTE)
29459 DO 280 I=1,MIN(8,MDCY(21,3))
29461 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29464 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
29465 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29472 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29480 ELSEIF(ISUB.EQ.58) THEN
29481 C...gamma + gamma -> f + fbar
29482 CALL PYWIDT(22,SH,WDTP,WDTE)
29484 DO 290 I=1,MIN(12,MDCY(22,3))
29485 IF(I.LE.8) EF= KCHG(I,1)/3D0
29486 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29487 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29490 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
29491 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29499 ELSEIF(ISUB.EQ.68) THEN
29501 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
29502 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
29504 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
29506 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
29512 SIGH(NCHN)=0.5D0*FACGG1
29517 SIGH(NCHN)=0.5D0*FACGG2
29522 SIGH(NCHN)=0.5D0*FACGG3
29525 ELSEIF(ISUB.EQ.80) THEN
29526 C...q + gamma -> q' + pi+/-
29527 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
29528 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
29529 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
29530 DELSH=UH*SQRT(ASSH*Q2FPSH)
29531 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
29532 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
29533 DELUH=SH*SQRT(ASUH*Q2FPUH)
29534 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
29535 IF(I.EQ.0) GOTO 320
29536 EI=KCHG(IABS(I),1)/3D0
29537 EJ=SIGN(1D0-ABS(EI),EI)
29539 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
29540 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
29543 ISIG(NCHN,3-ISDE)=22
29545 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
29550 ELSEIF(ISUB.LE.100) THEN
29551 IF(ISUB.EQ.91) THEN
29552 C...Elastic scattering
29553 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
29555 ELSEIF(ISUB.EQ.92) THEN
29556 C...Single diffractive scattering (first side, i.e. XB)
29557 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
29559 ELSEIF(ISUB.EQ.93) THEN
29560 C...Single diffractive scattering (second side, i.e. AX)
29561 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
29563 ELSEIF(ISUB.EQ.94) THEN
29564 C...Double diffractive scattering
29565 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
29567 ELSEIF(ISUB.EQ.95) THEN
29568 C...Low-pT scattering
29569 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
29571 ELSEIF(ISUB.EQ.96) THEN
29572 C...Multiple interactions: sum of QCD processes
29573 CALL PYWIDT(21,SH,WDTP,WDTE)
29575 C...q + q' -> q + q'
29576 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29577 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29578 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29579 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
29580 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
29581 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
29583 IF(I.EQ.0) GOTO 340
29585 IF(J.EQ.0) GOTO 330
29591 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29593 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
29598 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
29603 C...q + qbar -> q' + qbar' or g + g
29604 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29605 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
29606 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29608 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29611 IF(I.EQ.0) GOTO 350
29621 SIGH(NCHN)=0.5D0*FACGG1
29626 SIGH(NCHN)=0.5D0*FACGG2
29630 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29632 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29635 IF(I.EQ.0) GOTO 370
29639 ISIG(NCHN,3-ISDE)=21
29644 ISIG(NCHN,3-ISDE)=21
29650 C...g + g -> q + qbar (only d, u, s)
29653 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29654 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29655 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29656 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29657 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29658 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29659 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29660 & UH2/SH2)*FLAVWT*FACA
29661 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29662 & TH2/SH2)*FLAVWT*FACA
29674 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
29677 SQMAVG=PMAS(IFL,1)**2
29678 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29679 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29680 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29681 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29682 THUHQ=THQ*UHQ-SQMAVG*SH
29683 IF(MSTP(34).EQ.0) THEN
29684 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29685 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29687 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29688 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29689 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29690 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29692 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29693 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29697 ISIG(NCHN,3)=531+2*(IFL-3)
29702 ISIG(NCHN,3)=532+2*(IFL-3)
29708 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
29709 & 2D0*TH/SH+TH2/SH2)*FACA
29710 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
29711 & 2D0*SH/UH+SH2/UH2)*FACA
29712 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
29713 & 2D0*UH/TH+UH2/TH2)
29718 SIGH(NCHN)=0.5D0*FACGG1
29723 SIGH(NCHN)=0.5D0*FACGG2
29728 SIGH(NCHN)=0.5D0*FACGG3
29730 ELSEIF(ISUB.EQ.99) THEN
29731 C...f + gamma* -> f.
29732 IF(MINT(107).EQ.4) THEN
29741 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
29742 PM2RHO=PMAS(PYCOMP(113),1)**2
29743 IF(MSTP(19).EQ.0) THEN
29745 ELSEIF(MSTP(19).EQ.1) THEN
29746 COMFAC=COMFAC/(Q2GA+PM2RHO)
29747 ELSEIF(MSTP(19).EQ.2) THEN
29748 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29750 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29752 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
29753 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
29754 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
29755 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
29757 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
29759 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
29761 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
29762 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
29764 DO 390 I=MMINA,MMAXA
29765 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
29766 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
29767 EI=KCHG(IABS(I),1)/3D0
29770 ISIG(NCHN,3-ISDE)=22
29772 SIGH(NCHN)=COMFAC*EI**2
29777 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
29778 C...g + g -> gamma + gamma or g + g -> g + gamma
29793 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
29795 EI=KCHG(IABS(I),1)/3D0
29797 IF(ISUB.EQ.115) EIWT=EI
29802 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
29803 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
29806 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
29807 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
29808 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
29809 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
29815 CALL PYWAUX(1,EPSS,W1SR,W1SI)
29816 CALL PYWAUX(1,EPST,W1TR,W1TI)
29817 CALL PYWAUX(1,EPSU,W1UR,W1UI)
29818 CALL PYWAUX(2,EPSS,W2SR,W2SI)
29819 CALL PYWAUX(2,EPST,W2TR,W2TI)
29820 CALL PYWAUX(2,EPSU,W2UR,W2UI)
29821 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
29822 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
29823 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
29824 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
29825 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
29826 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
29827 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
29828 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
29829 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
29830 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
29831 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29832 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29833 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
29834 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
29835 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
29836 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
29837 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29838 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29839 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
29840 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
29841 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
29842 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
29843 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29844 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
29845 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
29846 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
29847 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
29848 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
29849 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29850 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
29851 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
29852 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
29853 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
29854 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
29855 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29856 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
29857 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
29858 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
29859 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
29860 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
29861 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29862 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
29863 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
29864 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
29865 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
29866 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29867 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
29868 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
29869 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
29870 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29871 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
29872 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
29873 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
29874 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
29875 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
29876 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
29878 A0STUR=A0STUR+EIWT*B0STUR
29879 A0STUI=A0STUI+EIWT*B0STUI
29880 A0TSUR=A0TSUR+EIWT*B0TSUR
29881 A0TSUI=A0TSUI+EIWT*B0TSUI
29882 A0UTSR=A0UTSR+EIWT*B0UTSR
29883 A0UTSI=A0UTSI+EIWT*B0UTSI
29884 A1STUR=A1STUR+EIWT*B1STUR
29885 A1STUI=A1STUI+EIWT*B1STUI
29886 A2STUR=A2STUR+EIWT*B2STUR
29887 A2STUI=A2STUI+EIWT*B2STUI
29889 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
29890 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
29891 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
29892 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
29893 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
29898 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
29899 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29902 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29903 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29905 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29907 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29909 IF(ISUB.EQ.131) THEN
29910 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29911 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29913 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29915 DO 430 I=MMINA,MMAXA
29916 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29917 EI=KCHG(IABS(I),1)/3D0
29920 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29921 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29924 ISIG(NCHN,3-ISDE)=22
29930 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29931 C...f + gamma*_(T,L) -> f + gamma
29933 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29935 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29937 IF(ISUB.EQ.133) THEN
29938 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29939 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29941 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29943 DO 450 I=MMINA,MMAXA
29944 IF(I.EQ.0) GOTO 450
29945 EI=KCHG(IABS(I),1)/3D0
29948 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29949 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29952 ISIG(NCHN,3-ISDE)=22
29958 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29959 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29961 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29963 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29965 CALL PYWIDT(21,SH,WDTP,WDTE)
29967 DO 460 I=1,MIN(8,MDCY(21,3))
29969 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29972 IF(ISUB.EQ.135) THEN
29973 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29974 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29976 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29978 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29985 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29993 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
29994 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
29996 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
29998 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
29999 CALL PYWIDT(22,SH,WDTP,WDTE)
30001 DO 470 I=1,MIN(12,MDCY(22,3))
30002 IF(I.LE.8) EF= KCHG(I,1)/3D0
30003 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30004 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30007 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30008 IF(ISUB.EQ.137) THEN
30009 FPARAM=-SH*(TH+UH)/DLAMB2
30010 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30011 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30012 & 2D0*PH1*PH2*FPARAM**2)
30013 ELSEIF(ISUB.EQ.138) THEN
30014 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30015 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30016 & 2D0*PH1**2*(TH-UH)**2)
30017 ELSEIF(ISUB.EQ.139) THEN
30018 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30019 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30020 & 2D0*PH2**2*(TH-UH)**2)
30022 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30023 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30025 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30039 C*********************************************************************
30042 C...Subprocess cross sections for heavy flavour production,
30043 C...open and closed.
30044 C...Auxiliary to PYSIGH.
30046 SUBROUTINE PYSGHF(NCHN,SIGS)
30048 C...Double precision and integer declarations
30049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30050 IMPLICIT INTEGER(I-N)
30051 INTEGER PYK,PYCHGE,PYCOMP
30052 C...Parameter statement to help give large particle numbers.
30053 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30054 &KEXCIT=4000000,KDIMEN=5000000)
30056 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30057 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30058 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30059 COMMON/PYINT1/MINT(400),VINT(400)
30060 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30061 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30062 COMMON/PYINT4/MWID(500),WIDS(500,5)
30063 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30064 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30065 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30066 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30067 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30070 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30072 C...Determine where are charmonium/bottomonium wave function parameters.
30074 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30076 C...Convert bottomonium process into equivalent charmonium ones.
30077 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30079 C...Differential cross section expressions.
30081 IF(ISUB.LE.100) THEN
30082 IF(ISUB.EQ.81) THEN
30083 C...q + qbar -> Q + Qbar
30084 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30085 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30086 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30087 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30089 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30091 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30092 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30094 DO 100 I=MMINA,MMAXA
30095 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30096 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30104 ELSEIF(ISUB.EQ.82) THEN
30105 C...g + g -> Q + Qbar
30106 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30107 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30108 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30109 THUHQ=THQ*UHQ-SQMAVG*SH
30110 IF(MSTP(34).EQ.0) THEN
30111 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30112 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30114 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30115 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30116 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30117 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30119 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30120 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30121 IF(MSTP(35).GE.1) THEN
30122 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30123 FACQQ1=FACQQ1*FATRE
30124 FACQQ2=FACQQ2*FATRE
30127 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30128 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30131 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30144 ELSEIF(ISUB.EQ.83) THEN
30145 C...f + q -> f' + Q
30146 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
30147 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
30148 DO 130 I=MMIN1,MMAX1
30149 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
30150 DO 120 J=MMIN2,MMAX2
30151 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
30152 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
30153 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
30154 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
30160 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30161 & (IABS(I)+1)/2)*VINT(180+J)
30162 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
30163 & (MINT(55)+1)/2)*VINT(180+J)
30166 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30167 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30170 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30171 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30174 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30175 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30177 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
30183 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30184 & (IABS(J)+1)/2)*VINT(180+I)
30185 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
30186 & (MINT(55)+1)/2)*VINT(180+I)
30188 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30189 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30192 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30193 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30196 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30197 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30202 ELSEIF(ISUB.EQ.84) THEN
30203 C...g + gamma -> Q + Qbar
30204 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30205 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30206 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30207 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
30208 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
30210 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
30212 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30213 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30215 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30222 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30230 ELSEIF(ISUB.EQ.85) THEN
30231 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
30232 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30233 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30234 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30235 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
30236 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
30237 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
30238 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
30239 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
30240 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
30241 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
30243 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
30244 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
30245 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
30247 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30255 ELSEIF(ISUB.EQ.86) THEN
30256 C...g + g -> J/Psi + g
30257 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
30258 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30259 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30260 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30268 ELSEIF(ISUB.EQ.87) THEN
30269 C...g + g -> chi_0c + g
30270 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30271 QGTW=(SH*TH*UH)/SH**3
30273 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30274 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30275 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
30276 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
30277 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
30278 & (QGTW*(QGTW-RGTW*PGTW)**4)
30279 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30287 ELSEIF(ISUB.EQ.88) THEN
30288 C...g + g -> chi_1c + g
30289 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30290 QGTW=(SH*TH*UH)/SH**3
30292 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30293 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
30294 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
30295 & (QGTW-RGTW*PGTW)**4
30296 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30304 ELSEIF(ISUB.EQ.89) THEN
30305 C...g + g -> chi_2c + g
30306 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30307 QGTW=(SH*TH*UH)/SH**3
30309 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30310 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30311 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
30312 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
30313 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
30314 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30315 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30324 ELSEIF(ISUB.LE.200) THEN
30325 IF(ISUB.EQ.104) THEN
30326 C...g + g -> chi_c0.
30328 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
30329 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30330 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30331 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30339 ELSEIF(ISUB.EQ.105) THEN
30340 C...g + g -> chi_c2.
30342 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
30343 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30344 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30345 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30353 ELSEIF(ISUB.EQ.106) THEN
30354 C...g + g -> J/Psi + gamma.
30355 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30356 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
30357 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30358 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30359 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30367 ELSEIF(ISUB.EQ.107) THEN
30368 C...g + gamma -> J/Psi + g.
30369 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30370 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
30371 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30372 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30373 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30380 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30388 ELSEIF(ISUB.EQ.108) THEN
30389 C...gamma + gamma -> J/Psi + gamma.
30390 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30391 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
30392 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30393 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30394 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30404 C...Additional code by Stefan Wolf
30407 C...Common code for quarkonium production.
30414 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
30415 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
30417 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
30418 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
30422 IF(MSTP(145).EQ.1) THEN
30423 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
30424 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
30425 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
30426 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
30427 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30428 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30429 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30430 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30431 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
30432 & ISUB.GE.437) THEN
30433 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
30434 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
30435 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30436 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30437 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30438 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30442 SMQQ2=SQMQQ*VINT(2)
30443 C...Polarisation frames
30444 IF(MSTP(146).EQ.1) THEN
30446 POLH1=SQRT(AQ2-SMQQ2)
30447 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30450 AX=AQ*BQ/(POLH1*POLH2)
30452 ELSEIF(MSTP(146).EQ.2) THEN
30453 C...Gottfried Jackson frame
30455 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30458 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
30459 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
30460 ELSEIF(MSTP(146).EQ.3) THEN
30463 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30466 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
30467 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
30468 ELSEIF(MSTP(146).EQ.4) THEN
30469 C...Collins Soper frame
30471 POLH2=SQRT(VINT(2)*POLH1)
30474 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
30475 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
30477 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
30478 EL1K10=AZ*ATILK1+BZ*BTILK1
30479 EL1K20=AZ*ATILK2+BZ*BTILK2
30482 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
30483 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
30488 IF(ISUB.EQ.421) THEN
30489 C...g + g -> QQ~[3S11] + g
30490 IF(MSTP(145).EQ.0) THEN
30491 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30492 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
30493 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30494 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
30495 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30496 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
30498 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
30499 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30503 IF(MSTP(147).EQ.0) THEN
30504 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30505 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30506 ELSEIF(MSTP(147).EQ.1) THEN
30507 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30508 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30509 ELSEIF(MSTP(147).EQ.3) THEN
30510 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30511 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30512 ELSEIF(MSTP(147).EQ.4) THEN
30513 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30514 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30515 ELSEIF(MSTP(147).EQ.5) THEN
30516 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30517 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30518 ELSEIF(MSTP(147).EQ.6) THEN
30519 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30520 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30522 FACQQG=COMFAC*FF*FACQQG
30524 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30529 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
30532 ELSEIF(ISUB.EQ.422) THEN
30533 C...g + g -> QQ~[3S18] + g
30534 IF(MSTP(145).EQ.0) THEN
30535 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
30536 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30538 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
30540 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30541 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
30542 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30546 IF(MSTP(147).EQ.0) THEN
30547 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30548 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30549 ELSEIF(MSTP(147).EQ.1) THEN
30550 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30551 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30552 ELSEIF(MSTP(147).EQ.3) THEN
30553 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30554 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30555 ELSEIF(MSTP(147).EQ.4) THEN
30556 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30557 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30558 ELSEIF(MSTP(147).EQ.5) THEN
30559 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30560 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30561 ELSEIF(MSTP(147).EQ.6) THEN
30562 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30563 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30565 FACQQG=COMFAC*FF*FACQQG
30567 C...Split total contribution into different colour flows just like
30568 C...in g g -> g g (recalculate kinematics for massless partons).
30569 THP=-0.5D0*SH*(1D0-CTH)
30570 UHP=-0.5D0*SH*(1D0+CTH)
30571 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30572 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30573 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30574 FACGGS=FACGG1+FACGG2+FACGG3
30575 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30580 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30585 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30590 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
30593 ELSEIF(ISUB.EQ.423) THEN
30594 C...g + g -> QQ~[1S08] + g
30595 IF(MSTP(145).EQ.0) THEN
30596 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
30597 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
30598 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
30599 * & (SHTH2*THUH2*UHSH2)
30600 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
30601 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30602 & TH2/(SHTH2*THUH2))*
30603 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30605 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
30606 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30607 & TH2/(SHTH2*THUH2))*
30608 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30609 IF(MSTP(147).EQ.0) THEN
30611 ELSEIF(MSTP(147).EQ.1) THEN
30612 FACQQG=COMFAC*2D0*FA
30613 ELSEIF(MSTP(147).EQ.3) THEN
30615 ELSEIF(MSTP(147).EQ.4) THEN
30617 ELSEIF(MSTP(147).EQ.5) THEN
30619 ELSEIF(MSTP(147).EQ.6) THEN
30623 C...Split total contribution into different colour flows just like
30624 C...in g g -> g g (recalculate kinematics for massless partons).
30625 THP=-0.5D0*SH*(1D0-CTH)
30626 UHP=-0.5D0*SH*(1D0+CTH)
30627 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30628 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30629 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30630 FACGGS=FACGG1+FACGG2+FACGG3
30631 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30636 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30641 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30646 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
30649 ELSEIF(ISUB.EQ.424) THEN
30650 C...g + g -> QQ~[3PJ8] + g
30652 IF(MSTP(145).EQ.0) THEN
30653 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
30654 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
30655 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
30657 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
30658 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
30659 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
30661 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
30662 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
30663 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
30665 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
30666 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
30667 & +451D0*SH*TH**5+126D0*TH**6)
30668 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
30669 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
30670 & +171D0*SH*TH**5+42D0*TH**6)
30671 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
30672 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
30673 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
30674 & +99D0*SH*TH**3+35D0*TH**4)
30675 & +7D0*SQMQQ**8*SHTH*POLY)/
30676 & (SH*TH*UH*SQMQQR*SQMQQ*
30677 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30679 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
30680 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30681 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
30682 & -SQMQQ*SHTH2*POLY**2*
30683 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
30684 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
30685 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
30686 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
30687 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
30688 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
30689 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
30690 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
30691 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
30692 & +145D0*SH*TH**5+34D0*TH**6)
30693 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
30694 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
30696 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
30697 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
30698 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
30699 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
30700 & +3D0*SQMQQ**8*SHTH*POLY)
30701 BB=4D0*SHTH2*POLY**3
30702 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
30703 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
30704 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
30705 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
30706 & +84D0*SH*TH**9+20D0*TH**10)
30707 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
30708 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
30709 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
30711 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
30712 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
30713 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
30715 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
30716 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
30717 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
30718 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
30719 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
30721 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
30722 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
30723 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
30725 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
30726 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
30727 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
30728 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
30730 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
30731 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
30732 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
30733 & +394D0*SH*TH**9+84D0*TH**10)
30734 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
30735 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
30736 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
30737 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
30738 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
30739 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
30740 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
30741 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
30742 & +266D0*SH*TH**6+84D0*TH**7)
30743 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
30744 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
30746 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
30747 & +7D0*SH*TH**3+4*TH**4)
30748 & +SQMQQ**8*SH*(SH-TH)**2*TH
30749 DD=2D0*TH2*SHTH2*POLY**3
30750 & *(-SH2+2*SH*TH+2*TH2)
30751 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
30752 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
30753 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
30754 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
30755 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
30756 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
30757 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
30758 & -210D0*SH*TH**8-60D0*TH**9)
30759 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
30760 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
30761 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
30763 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
30764 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
30765 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
30766 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
30767 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
30768 & -30D0*SH*TH**6-24D0*TH**7)
30769 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
30770 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
30772 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
30773 IF(MSTP(147).EQ.0) THEN
30774 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30775 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30776 ELSEIF(MSTP(147).EQ.1) THEN
30777 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30778 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30779 ELSEIF(MSTP(147).EQ.3) THEN
30780 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30781 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30782 ELSEIF(MSTP(147).EQ.4) THEN
30783 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30784 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30785 ELSEIF(MSTP(147).EQ.5) THEN
30786 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30787 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30788 ELSEIF(MSTP(147).EQ.6) THEN
30789 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30790 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30792 FACQQG=COMFAC*FF*FACQQG
30794 C...Split total contribution into different colour flows just like
30795 C...in g g -> g g (recalculate kinematics for massless partons).
30796 THP=-0.5D0*SH*(1D0-CTH)
30797 UHP=-0.5D0*SH*(1D0+CTH)
30798 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30799 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30800 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30801 FACGGS=FACGG1+FACGG2+FACGG3
30802 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30807 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30812 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30817 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
30820 ELSEIF(ISUB.EQ.425) THEN
30821 C...q + g -> q + QQ~[3S18]
30822 IF(MSTP(145).EQ.0) THEN
30823 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
30824 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
30825 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
30827 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
30828 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
30833 IF(MSTP(147).EQ.0) THEN
30834 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30835 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30836 ELSEIF(MSTP(147).EQ.1) THEN
30837 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30838 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30839 ELSEIF(MSTP(147).EQ.3) THEN
30840 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30841 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30842 ELSEIF(MSTP(147).EQ.4) THEN
30843 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30844 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30845 ELSEIF(MSTP(147).EQ.5) THEN
30846 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30847 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30848 ELSEIF(MSTP(147).EQ.6) THEN
30849 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30850 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30852 FACQQG=COMFAC*FF*FACQQG
30854 C...Split total contribution into different colour flows just like
30855 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30856 C...(recalculate kinematics for massless partons).
30857 THP=-0.5D0*SH*(1D0-CTH)
30858 UHP=-0.5D0*SH*(1D0+CTH)
30859 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30860 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30861 FACQGS=FACQG1+FACQG2
30862 DO 2442 I=MMINA,MMAXA
30863 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
30865 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
30866 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
30869 ISIG(NCHN,3-ISDE)=21
30871 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
30874 ISIG(NCHN,3-ISDE)=21
30876 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
30880 ELSEIF(ISUB.EQ.426) THEN
30881 C...q + g -> q + QQ~[1S08]
30882 IF(MSTP(145).EQ.0) THEN
30883 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
30884 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
30886 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
30887 IF(MSTP(147).EQ.0) THEN
30889 ELSEIF(MSTP(147).EQ.1) THEN
30890 FACQQG=COMFAC*2D0*FA
30891 ELSEIF(MSTP(147).EQ.3) THEN
30893 ELSEIF(MSTP(147).EQ.4) THEN
30895 ELSEIF(MSTP(147).EQ.5) THEN
30897 ELSEIF(MSTP(147).EQ.6) THEN
30901 C...Split total contribution into different colour flows just like
30902 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30903 C...(recalculate kinematics for massless partons).
30904 THP=-0.5D0*SH*(1D0-CTH)
30905 UHP=-0.5D0*SH*(1D0+CTH)
30906 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30907 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30908 FACQGS=FACQG1+FACQG2
30909 DO 2444 I=MMINA,MMAXA
30910 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30912 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30913 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30916 ISIG(NCHN,3-ISDE)=21
30918 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30921 ISIG(NCHN,3-ISDE)=21
30923 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30927 ELSEIF(ISUB.EQ.427) THEN
30928 C...q + g -> q + QQ~[3PJ8]
30929 IF(MSTP(145).EQ.0) THEN
30930 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30931 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30932 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30933 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30935 FF=10D0*PARU(1)*AS**3/
30936 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30937 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30938 BB=8D0*(SHTH2+TH*UH)
30939 CC=8D0*UHSH*(SHTH+THUH)
30940 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30941 IF(MSTP(147).EQ.0) THEN
30942 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30943 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30944 ELSEIF(MSTP(147).EQ.1) THEN
30945 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30946 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30947 ELSEIF(MSTP(147).EQ.3) THEN
30948 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30949 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30950 ELSEIF(MSTP(147).EQ.4) THEN
30951 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30952 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30953 ELSEIF(MSTP(147).EQ.5) THEN
30954 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30955 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30956 ELSEIF(MSTP(147).EQ.6) THEN
30957 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30958 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30960 FACQQG=COMFAC*FF*FACQQG
30962 C...Split total contribution into different colour flows just like
30963 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30964 C...(recalculate kinematics for massless partons).
30965 THP=-0.5D0*SH*(1D0-CTH)
30966 UHP=-0.5D0*SH*(1D0+CTH)
30967 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30968 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30969 FACQGS=FACQG1+FACQG2
30970 DO 2446 I=MMINA,MMAXA
30971 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30973 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30974 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30977 ISIG(NCHN,3-ISDE)=21
30979 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
30982 ISIG(NCHN,3-ISDE)=21
30984 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
30988 ELSEIF(ISUB.EQ.428) THEN
30989 C...q + q~ -> g + QQ~[3S18]
30990 IF(MSTP(145).EQ.0) THEN
30991 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
30992 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
30993 & (SQMQQ*SQMQQR*TH*UH*THUH2)
30995 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
30996 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31001 IF(MSTP(147).EQ.0) THEN
31002 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31003 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31004 ELSEIF(MSTP(147).EQ.1) THEN
31005 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31006 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31007 ELSEIF(MSTP(147).EQ.3) THEN
31008 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31009 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31010 ELSEIF(MSTP(147).EQ.4) THEN
31011 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31012 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31013 ELSEIF(MSTP(147).EQ.5) THEN
31014 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31015 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31016 ELSEIF(MSTP(147).EQ.6) THEN
31017 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31018 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31020 FACQQG=COMFAC*FF*FACQQG
31022 C...Split total contribution into different colour flows just like
31023 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31024 C...(recalculate kinematics for massless partons).
31025 THP=-0.5D0*SH*(1D0-CTH)
31026 UHP=-0.5D0*SH*(1D0+CTH)
31027 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31028 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31029 FACGGS=FACGG1+FACGG2
31030 DO 2447 I=MMINA,MMAXA
31031 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31032 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31037 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31042 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31045 ELSEIF(ISUB.EQ.429) THEN
31046 C...q + q~ -> g + QQ~[1S08]
31047 IF(MSTP(145).EQ.0) THEN
31048 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31049 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31051 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31052 IF(MSTP(147).EQ.0) THEN
31054 ELSEIF(MSTP(147).EQ.1) THEN
31055 FACQQG=COMFAC*2D0*FA
31056 ELSEIF(MSTP(147).EQ.3) THEN
31058 ELSEIF(MSTP(147).EQ.4) THEN
31060 ELSEIF(MSTP(147).EQ.5) THEN
31062 ELSEIF(MSTP(147).EQ.6) THEN
31066 C...Split total contribution into different colour flows just like
31067 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31068 C...(recalculate kinematics for massless partons).
31069 THP=-0.5D0*SH*(1D0-CTH)
31070 UHP=-0.5D0*SH*(1D0+CTH)
31071 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31072 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31073 FACGGS=FACGG1+FACGG2
31074 DO 2448 I=MMINA,MMAXA
31075 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31076 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31081 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31086 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31089 ELSEIF(ISUB.EQ.430) THEN
31090 C...q + q~ -> g + QQ~[3PJ8]
31091 IF(MSTP(145).EQ.0) THEN
31092 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31093 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31094 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31095 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31097 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31098 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31099 BB=8D0*(UHSH2+SH*TH)
31100 CC=8D0*(SHTH2+SH*UH)
31101 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31102 IF(MSTP(147).EQ.0) THEN
31103 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31104 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31105 ELSEIF(MSTP(147).EQ.1) THEN
31106 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31107 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31108 ELSEIF(MSTP(147).EQ.3) THEN
31109 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31110 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31111 ELSEIF(MSTP(147).EQ.4) THEN
31112 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31113 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31114 ELSEIF(MSTP(147).EQ.5) THEN
31115 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31116 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31117 ELSEIF(MSTP(147).EQ.6) THEN
31118 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31119 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31121 FACQQG=COMFAC*FF*FACQQG
31123 C...Split total contribution into different colour flows just like
31124 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31125 C...(recalculate kinematics for massless partons).
31126 THP=-0.5D0*SH*(1D0-CTH)
31127 UHP=-0.5D0*SH*(1D0+CTH)
31128 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31129 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31130 FACGGS=FACGG1+FACGG2
31131 DO 2449 I=MMINA,MMAXA
31132 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31133 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
31138 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31143 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31146 ELSEIF(ISUB.EQ.431) THEN
31147 C...g + g -> QQ~[3P01] + g
31148 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31149 QGTW=(SH*TH*UH)/SH**3
31151 IF(MSTP(145).EQ.0) THEN
31152 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31153 & (9D0*RGTW**2*PGTW**4*
31154 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31155 & -6D0*RGTW*PGTW**3*QGTW*
31156 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31157 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31158 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31159 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31161 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
31162 & (9D0*RGTW**2*PGTW**4*
31163 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31164 & -6D0*RGTW*PGTW**3*QGTW*
31165 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31166 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31167 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31168 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31169 IF(MSTP(147).EQ.0) THEN
31171 ELSEIF(MSTP(147).EQ.1) THEN
31172 FACQQG=COMFAC*2D0*FC1
31173 ELSEIF(MSTP(147).EQ.3) THEN
31175 ELSEIF(MSTP(147).EQ.4) THEN
31177 ELSEIF(MSTP(147).EQ.5) THEN
31179 ELSEIF(MSTP(147).EQ.6) THEN
31183 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31188 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31191 ELSEIF(ISUB.EQ.432) THEN
31192 C...g + g -> QQ~[3P11] + g
31193 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31194 QGTW=(SH*TH*UH)/SH**3
31196 IF(MSTP(145).EQ.0) THEN
31197 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
31198 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
31199 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
31200 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
31202 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
31203 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
31204 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
31205 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
31206 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
31207 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31208 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31209 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
31210 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31211 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31212 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
31213 C4=-4D0*THUH*(TH-UH)**2*
31214 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
31215 & -SH2*TH*UH*(TH2+UH2))
31216 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
31217 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
31218 & +SH2*(5D0*THUH2-17D0*TH*UH)))
31219 IF(MSTP(147).EQ.0) THEN
31220 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31221 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31222 ELSEIF(MSTP(147).EQ.1) THEN
31223 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31224 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31225 ELSEIF(MSTP(147).EQ.3) THEN
31226 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31227 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31228 ELSEIF(MSTP(147).EQ.4) THEN
31229 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31230 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31231 ELSEIF(MSTP(147).EQ.5) THEN
31232 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31233 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31234 ELSEIF(MSTP(147).EQ.6) THEN
31235 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31236 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31238 FACQQG=COMFAC*FF*FACQQG
31240 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31245 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31248 ELSEIF(ISUB.EQ.433) THEN
31249 C...g + g -> QQ~[3P21] + g
31250 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31251 QGTW=(SH*TH*UH)/SH**3
31253 IF(MSTP(145).EQ.0) THEN
31254 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31255 & (12D0*RGTW**2*PGTW**4*
31256 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31257 & -3D0*RGTW*PGTW**3*QGTW*
31258 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
31259 & +2D0*PGTW**2*QGTW**2*
31260 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
31261 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
31262 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31264 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
31265 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
31266 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
31268 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
31269 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
31270 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
31271 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
31272 & +10D0*(SH2**2+TH2**2))
31273 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
31274 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
31275 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
31276 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
31277 & +4D0*SH*TH*UH2**4*SHTH2)
31278 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
31279 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
31280 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
31281 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
31282 & +10D0*(SH2**2+UH2**2))
31283 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
31284 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
31285 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
31286 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
31287 & +4D0*SH*UH*TH2**4*UHSH2)
31288 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
31289 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
31290 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
31291 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
31292 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
31293 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
31294 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
31295 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
31296 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
31297 & +3D0*(TH2**3+UH2**3)))
31298 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
31299 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
31300 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
31301 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
31302 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
31303 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
31304 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
31306 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
31308 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
31310 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
31311 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
31312 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
31313 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
31314 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
31315 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
31317 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
31319 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
31321 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
31322 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
31323 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
31324 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
31325 & +4D0*SH*TH2**2*UH2**2*THUH2
31326 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
31327 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
31328 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
31329 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
31330 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31331 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
31332 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
31333 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
31334 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
31335 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
31336 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
31337 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
31338 & +2D0*(TH2**3+UH2**3))
31339 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
31340 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
31341 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
31342 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31343 IF(MSTP(147).EQ.0) THEN
31344 FACQQG=1D0/3D0*(C1*3D0
31345 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31346 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31347 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31348 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31349 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31350 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31351 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31352 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31353 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31354 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31355 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31356 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31357 ELSEIF(MSTP(147).EQ.1) THEN
31359 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31360 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31361 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31362 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31363 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31364 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31365 & +EL1K10*EL2K20*EL1K11*EL2K11)
31366 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31367 & +EL1K10*EL2K20*EL1K21*EL2K21)
31368 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31369 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31370 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31371 & +EL1K20*EL2K20*EL1K11*EL2K11)
31372 ELSEIF(MSTP(147).EQ.2) THEN
31374 & -C2*EL1K11*EL2K11
31375 & -C3*EL1K21*EL2K21
31376 & -C4*EL1K11*EL2K21
31377 & +C5*(EL1K11*EL2K11)**2
31378 & +C6*(EL1K21*EL2K21)**2
31379 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31380 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31381 & +(C9+C0)*(EL1K11*EL2K21)**2)
31383 FACQQG=COMFAC*FF*FACQQG
31385 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31390 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31393 ELSEIF(ISUB.EQ.434) THEN
31394 C...q + g -> q + QQ~[3P01]
31395 IF(MSTP(145).EQ.0) THEN
31396 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
31397 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31399 FA=-PARU(1)*AS**3*(16D0/243D0)*
31400 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31401 IF(MSTP(147).EQ.0) THEN
31403 ELSEIF(MSTP(147).EQ.1) THEN
31404 FACQQG=COMFAC*2D0*FA
31405 ELSEIF(MSTP(147).EQ.3) THEN
31407 ELSEIF(MSTP(147).EQ.4) THEN
31409 ELSEIF(MSTP(147).EQ.5) THEN
31411 ELSEIF(MSTP(147).EQ.6) THEN
31415 DO 2452 I=MMINA,MMAXA
31416 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
31418 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
31419 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
31422 ISIG(NCHN,3-ISDE)=21
31424 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31428 ELSEIF(ISUB.EQ.435) THEN
31429 C...q + g -> q + QQ~[3P11]
31430 IF(MSTP(145).EQ.0) THEN
31431 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
31432 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
31434 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
31439 IF(MSTP(147).EQ.0) THEN
31440 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31441 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31442 ELSEIF(MSTP(147).EQ.1) THEN
31443 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31444 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31445 ELSEIF(MSTP(147).EQ.3) THEN
31446 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31447 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31448 ELSEIF(MSTP(147).EQ.4) THEN
31449 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31450 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31451 ELSEIF(MSTP(147).EQ.5) THEN
31452 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31453 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31454 ELSEIF(MSTP(147).EQ.6) THEN
31455 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31456 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31458 FACQQG=COMFAC*FF*FACQQG
31460 DO 2454 I=MMINA,MMAXA
31461 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
31463 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
31464 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
31467 ISIG(NCHN,3-ISDE)=21
31469 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31473 ELSEIF(ISUB.EQ.436) THEN
31474 C...q + g -> q + QQ~[3P21]
31475 IF(MSTP(145).EQ.0) THEN
31476 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
31477 & ((6D0*SQMQQ**2+TH2)*UHSH2
31478 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
31479 & (SQMQQR*TH*UHSH2**2)
31481 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
31483 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
31492 IF(MSTP(147).EQ.0) THEN
31493 FACQQG=1D0/3D0*(C1*3D0
31494 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31495 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31496 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31497 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31498 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31499 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31500 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31501 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31502 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31503 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31504 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31505 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31506 ELSEIF(MSTP(147).EQ.1) THEN
31508 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31509 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31510 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31511 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31512 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31513 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31514 & +EL1K10*EL2K20*EL1K11*EL2K11)
31515 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31516 & +EL1K10*EL2K20*EL1K21*EL2K21)
31517 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31518 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31519 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31520 & +EL1K20*EL2K20*EL1K11*EL2K11)
31521 ELSEIF(MSTP(147).EQ.2) THEN
31523 & -C2*EL1K11*EL2K11
31524 & -C3*EL1K21*EL2K21
31525 & -C4*EL1K11*EL2K21
31526 & +C5*(EL1K11*EL2K11)**2
31527 & +C6*(EL1K21*EL2K21)**2
31528 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31529 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31530 & +(C9+C0)*(EL1K11*EL2K21)**2)
31532 FACQQG=COMFAC*FF*FACQQG
31534 DO 2456 I=MMINA,MMAXA
31535 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
31537 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
31538 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
31541 ISIG(NCHN,3-ISDE)=21
31543 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31547 ELSEIF(ISUB.EQ.437) THEN
31548 C...q + q~ -> g + QQ~[3P01]
31549 IF(MSTP(145).EQ.0) THEN
31550 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
31551 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31553 FA=PARU(1)*AS**3*(128D0/729D0)*
31554 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31555 IF(MSTP(147).EQ.0) THEN
31557 ELSEIF(MSTP(147).EQ.1) THEN
31558 FACQQG=COMFAC*2D0*FA
31559 ELSEIF(MSTP(147).EQ.3) THEN
31561 ELSEIF(MSTP(147).EQ.4) THEN
31563 ELSEIF(MSTP(147).EQ.5) THEN
31565 ELSEIF(MSTP(147).EQ.6) THEN
31569 DO 2457 I=MMINA,MMAXA
31570 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31571 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
31576 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31579 ELSEIF(ISUB.EQ.438) THEN
31580 C...q + q~ -> g + QQ~[3P11]
31581 IF(MSTP(145).EQ.0) THEN
31582 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
31583 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
31585 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
31590 IF(MSTP(147).EQ.0) THEN
31591 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31592 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31593 ELSEIF(MSTP(147).EQ.1) THEN
31594 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31595 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31596 ELSEIF(MSTP(147).EQ.3) THEN
31597 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31598 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31599 ELSEIF(MSTP(147).EQ.4) THEN
31600 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31601 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31602 ELSEIF(MSTP(147).EQ.5) THEN
31603 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31604 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31605 ELSEIF(MSTP(147).EQ.6) THEN
31606 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31607 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31609 FACQQG=COMFAC*FF*FACQQG
31611 DO 2458 I=MMINA,MMAXA
31612 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31613 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
31618 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31621 ELSEIF(ISUB.EQ.439) THEN
31622 C...q + q~ -> g + QQ~[3P21]
31623 IF(MSTP(145).EQ.0) THEN
31624 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
31625 & ((6D0*SQMQQ**2+SH2)*THUH2
31626 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
31627 & (SQMQQR*SH*THUH2**2)
31629 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
31631 C2=4D0*(SH2+UH2+2D0*SH*THUH)
31632 C3=4D0*(SH2+TH2+2D0*SH*THUH)
31633 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
31640 IF(MSTP(147).EQ.0) THEN
31641 FACQQG=1D0/3D0*(C1*3D0
31642 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31643 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31644 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31645 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31646 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31647 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31648 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31649 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31650 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31651 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31652 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31653 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31654 ELSEIF(MSTP(147).EQ.1) THEN
31656 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31657 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31658 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31659 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31660 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31661 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31662 & +EL1K10*EL2K20*EL1K11*EL2K11)
31663 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31664 & +EL1K10*EL2K20*EL1K21*EL2K21)
31665 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31666 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31667 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31668 & +EL1K20*EL2K20*EL1K11*EL2K11)
31669 ELSEIF(MSTP(147).EQ.2) THEN
31671 & -C2*EL1K11*EL2K11
31672 & -C3*EL1K21*EL2K21
31673 & -C4*EL1K11*EL2K21
31674 & +C5*(EL1K11*EL2K11)**2
31675 & +C6*(EL1K21*EL2K21)**2
31676 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31677 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31678 & +(C9+C0)*(EL1K11*EL2K21)**2)
31680 FACQQG=COMFAC*FF*FACQQG
31682 DO 2459 I=MMINA,MMAXA
31683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31684 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
31689 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31699 C*********************************************************************
31702 C...Subprocess cross sections for W/Z processes,
31703 C...except that longitudinal WW scattering is in Higgs sector.
31704 C...Auxiliary to PYSIGH.
31706 SUBROUTINE PYSGWZ(NCHN,SIGS)
31708 C...Double precision and integer declarations
31709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31710 IMPLICIT INTEGER(I-N)
31711 INTEGER PYK,PYCHGE,PYCOMP
31712 C...Parameter statement to help give large particle numbers.
31713 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31714 &KEXCIT=4000000,KDIMEN=5000000)
31716 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31717 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31718 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31719 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31720 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31721 COMMON/PYINT1/MINT(400),VINT(400)
31722 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31723 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31724 COMMON/PYINT4/MWID(500),WIDS(500,5)
31725 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
31726 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31727 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31728 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31729 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31730 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
31731 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
31732 C...Local arrays and complex numbers
31733 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
31735 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
31737 C...Differential cross section expressions.
31739 IF(ISUB.LE.20) THEN
31741 C...f + fbar -> gamma*/Z0
31743 CALL PYWIDT(23,SH,WDTP,WDTE)
31745 FACZ=4D0*COMFAC*3D0
31748 DO 100 I=MMINA,MMAXA
31749 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31750 EI=KCHG(IABS(I),1)/3D0
31754 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
31756 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
31761 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
31762 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
31763 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
31764 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
31767 ELSEIF(ISUB.EQ.2) THEN
31768 C...f + fbar' -> W+/-
31769 CALL PYWIDT(24,SH,WDTP,WDTE)
31771 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
31772 HP=AEM/(24D0*XW)*SH
31773 DO 120 I=MMIN1,MMAX1
31774 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31776 DO 110 J=MMIN2,MMAX2
31777 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31779 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
31780 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31782 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31784 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
31789 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
31790 SIGH(NCHN)=HI*FACBW*HF
31794 ELSEIF(ISUB.EQ.15) THEN
31795 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
31796 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31797 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31801 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31802 DO 130 I=1,MIN(16,MDCY(23,3))
31804 IF(MDME(IDC,1).LT.0) GOTO 130
31806 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31810 AF=SIGN(1D0,EF+0.1D0)
31812 ELSEIF(I.LE.16) THEN
31814 AF=SIGN(1D0,EF+0.1D0)
31817 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31818 IF(4D0*RM1.LT.1D0) THEN
31820 IF(I.LE.8) FCOF=3D0*RADC4
31821 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31823 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31824 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31825 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31826 & AF**2*(1D0-4D0*RM1))*BE34
31830 C...Propagators: as simulated in PYOFSH and as desired
31831 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31835 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31837 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31838 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31839 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31840 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31841 C...Loop over flavours; consider full gamma/Z structure
31842 DO 140 I=MMINA,MMAXA
31843 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31844 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
31845 EI=KCHG(IABS(I),1)/3D0
31852 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
31853 & (VI**2+AI**2)*HFZZ)/HBW4
31856 ELSEIF(ISUB.EQ.16) THEN
31857 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
31858 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31859 C...Propagators: as simulated in PYOFSH and as desired
31860 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31861 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31862 GMMWC=SQRT(SQM4)*WDTP(0)
31863 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31864 FACWG=FACWG*HBW4C/HBW4
31865 DO 160 I=MMIN1,MMAX1
31867 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
31868 DO 150 J=MMIN2,MMAX2
31870 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
31871 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
31872 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31873 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31874 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31879 SIGH(NCHN)=FACWG*FCKM*WIDSC
31883 ELSEIF(ISUB.EQ.19) THEN
31884 C...f + fbar -> gamma + (gamma*/Z0)
31885 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31886 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31890 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31891 DO 170 I=1,MIN(16,MDCY(23,3))
31893 IF(MDME(IDC,1).LT.0) GOTO 170
31895 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31899 AF=SIGN(1D0,EF+0.1D0)
31901 ELSEIF(I.LE.16) THEN
31903 AF=SIGN(1D0,EF+0.1D0)
31906 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31907 IF(4D0*RM1.LT.1D0) THEN
31909 IF(I.LE.8) FCOF=3D0*RADC4
31910 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31912 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31913 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31914 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31915 & AF**2*(1D0-4D0*RM1))*BE34
31919 C...Propagators: as simulated in PYOFSH and as desired
31920 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31924 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31926 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31927 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31928 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31929 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31930 C...Loop over flavours; consider full gamma/Z structure
31931 DO 180 I=MMINA,MMAXA
31932 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31933 EI=KCHG(IABS(I),1)/3D0
31937 IF(IABS(I).LE.10) FCOI=FACA/3D0
31942 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31943 & (VI**2+AI**2)*HFZZ)/HBW4
31946 ELSEIF(ISUB.EQ.20) THEN
31947 C...f + fbar' -> gamma + W+/-
31948 FACGW=COMFAC*0.5D0*AEM**2/XW
31949 C...Propagators: as simulated in PYOFSH and as desired
31950 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31951 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31952 GMMWC=SQRT(SQM4)*WDTP(0)
31953 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31954 FACGW=FACGW*HBW4C/HBW4
31955 C...Anomalous couplings
31956 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31959 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31960 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31961 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31962 & (4D0*SQMW))/(TH+UH)**2
31964 DO 200 I=MMIN1,MMAX1
31966 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31967 DO 190 J=MMIN2,MMAX2
31969 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31970 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31971 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31973 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31974 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31976 FACWR=UH/(TH+UH)-1D0/3D0
31977 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31984 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
31989 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
31994 ELSEIF(ISUB.LE.40) THEN
31995 IF(ISUB.EQ.22) THEN
31996 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
31997 C...Kinematics dependence
31998 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
31999 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32000 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32006 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32007 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32008 DO 230 I=1,MIN(16,MDCY(23,3))
32010 IF(MDME(IDC,1).LT.0) GOTO 230
32012 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32013 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32016 AF=SIGN(1D0,EF+0.1D0)
32018 ELSEIF(I.LE.16) THEN
32020 AF=SIGN(1D0,EF+0.1D0)
32023 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32024 IF(4D0*RM1.LT.1D0) THEN
32026 IF(I.LE.8) FCOF=3D0*RADC3
32027 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32029 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32030 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32031 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32032 & AF**2*(1D0-4D0*RM1))*BE34
32035 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32036 IF(4D0*RM1.LT.1D0) THEN
32038 IF(I.LE.8) FCOF=3D0*RADC4
32039 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32041 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32042 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32043 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32044 & AF**2*(1D0-4D0*RM1))*BE34
32048 C...Propagators: as simulated in PYOFSH and as desired
32049 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32050 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32054 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32056 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32058 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32059 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32060 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32065 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32067 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32069 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32070 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32071 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32073 C...Loop over flavours; separate left- and right-handed couplings
32074 DO 270 I=MMINA,MMAXA
32075 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32076 EI=KCHG(IABS(I),1)/3D0
32082 IF(IABS(I).LE.10) FCOI=FACA/3D0
32084 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32085 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32086 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32087 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32089 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32090 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32091 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32092 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32097 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32100 ELSEIF(ISUB.EQ.23) THEN
32101 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32102 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32103 FACZW=FACZW*WIDS(23,2)
32104 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32105 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32106 DO 290 I=MMIN1,MMAX1
32108 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32109 DO 280 J=MMIN2,MMAX2
32111 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32112 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32113 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32115 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32117 AI=SIGN(1D0,EI+0.1D0)
32120 AJ=SIGN(1D0,EJ+0.1D0)
32122 IF(VI+AI.GT.0) THEN
32131 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32133 IF(IA.LE.10) FCOI=FACA/3D0
32138 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
32139 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
32140 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
32141 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
32142 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
32143 & WIDS(24,(5-KCHW)/2)
32144 C***Protect against slightly negative cross sections. (Reason yet to be
32145 C***sorted out. One possibility: addition of width to the W propagator.)
32146 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
32150 ELSEIF(ISUB.EQ.25) THEN
32151 C...f + fbar -> W+ + W-
32152 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32154 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
32155 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32156 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32157 GMMW3=SQRT(SQM3)*WDTP(0)
32158 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32159 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32160 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32161 GMMW4=SQRT(SQM4)*WDTP(0)
32162 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
32163 C...Kinematical functions
32164 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32165 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
32166 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
32167 GT=THUH34+4D0*THUH/TH2
32168 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
32169 GU=THUH34+4D0*THUH/UH2
32170 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
32171 C...Common factors and couplings
32172 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
32173 FACWW=FACWW*WIDS(24,1)
32175 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
32176 CZZ=AEM**2/(32D0*XW**2)*HBWZC
32177 CNG=AEM**2/(4D0*XW)
32178 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
32179 CNN=AEM**2/(16D0*XW**2)
32180 C...Coulomb factor for W+W- pair
32181 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
32182 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
32183 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
32184 IF(COULE.LT.100D0*PMAS(24,2)) THEN
32185 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32186 & PMAS(24,2)**2)-COULE))
32188 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
32190 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
32191 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32192 & PMAS(24,2)**2)+COULE))
32194 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
32197 IF(MSTP(40).EQ.1) THEN
32198 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
32199 & MAX(1D-10,2D0*COULP*COULP1))
32200 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32201 ELSEIF(MSTP(40).EQ.2) THEN
32202 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
32203 COULCP=DCMPLX(0D0,DBLE(COULP))
32204 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
32205 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
32206 & (4D0*COULCP)*LOG(COULCD)
32207 COULCS=DCMPLX(0D0,0D0)
32210 COULXX=(ISTP-0.5)/NSTP
32211 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
32212 & (1D0+COULXX/COULCD))
32214 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
32216 FACCOU=ABS(COULCR)**2
32217 ELSEIF(MSTP(40).EQ.3) THEN
32218 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
32219 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
32220 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32222 ELSEIF(MSTP(40).EQ.4) THEN
32223 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
32229 C...Loop over allowed flavours
32230 DO 310 I=MMINA,MMAXA
32231 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
32232 EI=KCHG(IABS(I),1)/3D0
32233 AI=SIGN(1D0,EI+0.1D0)
32236 IF(IABS(I).LE.10) FCOI=FACA/3D0
32237 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
32239 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
32240 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
32242 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
32243 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
32246 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
32247 BET=SQRT(1D0-4D0*XMW02/SH)
32248 GAT=1D0/SQRT(1D0-BET**2)
32250 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
32251 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
32252 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
32253 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
32254 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
32255 & (1D0-2D0*BET*CTH+BET**2))
32256 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
32257 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
32258 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
32259 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
32260 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
32261 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
32262 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
32269 SIGH(NCHN)=FACWW*FCOI*DSIGWW
32272 ELSEIF(ISUB.EQ.30) THEN
32273 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
32274 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
32276 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32280 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32281 DO 320 I=1,MIN(16,MDCY(23,3))
32283 IF(MDME(IDC,1).LT.0) GOTO 320
32285 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32289 AF=SIGN(1D0,EF+0.1D0)
32291 ELSEIF(I.LE.16) THEN
32293 AF=SIGN(1D0,EF+0.1D0)
32296 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32297 IF(4D0*RM1.LT.1D0) THEN
32299 IF(I.LE.8) FCOF=3D0*RADC4
32300 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32302 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32303 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32304 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32305 & AF**2*(1D0-4D0*RM1))*BE34
32309 C...Propagators: as simulated in PYOFSH and as desired
32310 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32314 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32316 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32317 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32318 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32319 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32320 C...Loop over flavours; consider full gamma/Z structure
32321 DO 340 I=MMINA,MMAXA
32322 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
32323 EI=KCHG(IABS(I),1)/3D0
32326 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
32327 & (VI**2+AI**2)*HFZZ)/HBW4
32329 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
32330 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
32333 ISIG(NCHN,3-ISDE)=21
32339 ELSEIF(ISUB.EQ.31) THEN
32340 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
32341 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
32342 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
32343 C...Propagators: as simulated in PYOFSH and as desired
32344 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32345 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32346 GMMWC=SQRT(SQM4)*WDTP(0)
32347 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32348 FACWQ=FACWQ*HBW4C/HBW4
32349 DO 360 I=MMINA,MMAXA
32350 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
32352 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32353 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32355 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
32356 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
32359 ISIG(NCHN,3-ISDE)=21
32361 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32365 ELSEIF(ISUB.EQ.35) THEN
32366 C...f + gamma -> f + (gamma*/Z0)
32367 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
32368 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
32369 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
32370 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
32371 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
32372 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
32374 FZQN=SH2+UH2+2D0*SQM4*TH
32377 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
32378 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32382 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32383 DO 370 I=1,MIN(16,MDCY(23,3))
32385 IF(MDME(IDC,1).LT.0) GOTO 370
32387 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32391 AF=SIGN(1D0,EF+0.1D0)
32393 ELSEIF(I.LE.16) THEN
32395 AF=SIGN(1D0,EF+0.1D0)
32398 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32399 IF(4D0*RM1.LT.1D0) THEN
32401 IF(I.LE.8) FCOF=3D0*RADC4
32402 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32404 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32405 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32406 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32407 & AF**2*(1D0-4D0*RM1))*BE34
32411 C...Propagators: as simulated in PYOFSH and as desired
32412 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32416 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32418 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32419 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32420 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32421 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32422 C...Loop over flavours; consider full gamma/Z structure
32423 DO 390 I=MMINA,MMAXA
32424 IF(I.EQ.0) GOTO 390
32425 EI=KCHG(IABS(I),1)/3D0
32428 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32429 & (VI**2+AI**2)*HFZZ)/HBW4
32430 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
32432 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
32433 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
32436 ISIG(NCHN,3-ISDE)=22
32438 SIGH(NCHN)=FACZQ*FZQN/FZQD
32442 ELSEIF(ISUB.EQ.36) THEN
32443 C...f + gamma -> f' + W+/-
32444 FWQ=COMFAC*AEM**2/(2D0*XW)*
32445 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
32446 C...Propagators: as simulated in PYOFSH and as desired
32447 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32448 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32449 GMMWC=SQRT(SQM4)*WDTP(0)
32450 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32452 DO 410 I=MMINA,MMAXA
32453 IF(I.EQ.0) GOTO 410
32455 EIA=ABS(KCHG(IABS(I),1)/3D0)
32456 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
32457 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32458 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32460 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
32461 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
32464 ISIG(NCHN,3-ISDE)=22
32466 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32471 ELSEIF(ISUB.LE.100) THEN
32472 IF(ISUB.EQ.69) THEN
32473 C...gamma + gamma -> W+ + W-
32474 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32475 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
32476 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
32477 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
32478 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
32486 ELSEIF(ISUB.EQ.70) THEN
32487 C...gamma + W+/- -> Z0 + W+/-
32488 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32489 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
32490 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
32491 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
32492 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
32493 DO 440 KCHW=1,-1,-2
32495 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
32498 ISIG(NCHN,3-ISDE)=24*KCHW
32500 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
32509 C*********************************************************************
32512 C...Subprocess cross sections for Higgs processes,
32513 C...except Higgs pairs in PYSGSU, but including WW scattering.
32514 C...Auxiliary to PYSIGH.
32516 SUBROUTINE PYSGHG(NCHN,SIGS)
32518 C...Double precision and integer declarations
32519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32520 IMPLICIT INTEGER(I-N)
32521 INTEGER PYK,PYCHGE,PYCOMP
32522 C...Parameter statement to help give large particle numbers.
32523 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32524 &KEXCIT=4000000,KDIMEN=5000000)
32526 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32527 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32528 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32529 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32530 COMMON/PYINT1/MINT(400),VINT(400)
32531 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32532 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32533 COMMON/PYINT4/MWID(500),WIDS(500,5)
32534 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32535 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32536 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32537 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32538 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32539 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32540 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
32541 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
32542 C...Local arrays and complex variables
32543 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32544 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
32545 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
32547 C...Convert H or A process into equivalent h one
32550 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
32551 KFHIGG=KFPR(ISUB,1)
32553 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
32554 &ISUB.LE.190)) THEN
32556 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
32558 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
32559 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
32560 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
32561 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
32562 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
32563 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
32564 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
32565 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
32566 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
32567 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
32568 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
32569 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
32571 SQMH=PMAS(KFHIGG,1)**2
32572 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
32574 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32575 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
32576 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
32577 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
32578 IF(MSTP(46).LE.4) THEN
32579 HDTLH=LOG(PMAS(25,1)/PARP(44))
32580 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
32581 HDTNR=-1D0/18D0+HDTLH/6D0
32583 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
32584 HDTLQ=LOG(PARP(45)/PARP(44))
32585 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
32586 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
32589 C...Calculate lowest and next-to-lowest order partial wave amplitudes
32590 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
32594 HDTLS=LOG(SH/PARP(44)**2)
32595 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32596 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
32597 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
32598 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32599 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
32600 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
32601 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
32602 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
32604 C...Unitarize partial wave amplitudes with Pade or K-matrix method
32605 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
32606 A00U=A00L/(1D0-A004/A00L)
32607 A20U=A20L/(1D0-A204/A20L)
32608 A11U=A11L/(1D0-A114/A11L)
32610 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
32611 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
32612 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
32616 C...Differential cross section expressions.
32618 IF(ISUB.LE.60) THEN
32620 C...f + fbar -> h0 (or H0, or A0)
32621 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32623 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32624 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32626 HP=AEM/(8D0*XW)*SH/SQMW*SH
32627 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32628 DO 100 I=MMINA,MMAXA
32629 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32631 RMQ=PYMRUN(IA,SH)**2/SH
32633 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
32634 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32636 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32637 IF(IA.GT.10) IKFI=3
32638 HI=HI*PARU(150+10*IHIGG+IKFI)**2
32639 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32640 HI=HI/(1D0+RMSS(41))**2
32641 IF(IHIGG.NE.3) THEN
32642 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32643 & PARU(151+10*IHIGG))**2
32651 SIGH(NCHN)=HI*FACBW*HF
32654 ELSEIF(ISUB.EQ.5) THEN
32656 CALL PYWIDT(25,SH,WDTP,WDTE)
32658 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32659 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32660 HP=AEM/(8D0*XW)*SH/SQMW*SH
32661 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32663 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
32664 DO 120 I=MMIN1,MMAX1
32665 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32666 DO 110 J=MMIN2,MMAX2
32667 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32668 EI=KCHG(IABS(I),1)/3D0
32671 EJ=KCHG(IABS(J),1)/3D0
32678 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
32682 ELSEIF(ISUB.EQ.8) THEN
32684 CALL PYWIDT(25,SH,WDTP,WDTE)
32686 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32687 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32688 HP=AEM/(8D0*XW)*SH/SQMW*SH
32689 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32691 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
32692 DO 140 I=MMIN1,MMAX1
32693 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
32694 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32695 DO 130 J=MMIN2,MMAX2
32696 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
32697 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32698 IF(EI*EJ.GT.0D0) GOTO 130
32703 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
32707 ELSEIF(ISUB.EQ.24) THEN
32708 C...f + fbar -> Z0 + h0 (or H0, or A0)
32709 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
32710 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32711 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32712 GMMZ3=SQRT(SQM3)*WDTP(0)
32713 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
32714 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32715 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32716 GMMH4=SQRT(SQM4)*WDTP(0)
32717 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32718 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32719 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
32720 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
32721 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
32722 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
32723 & PARU(154+10*IHIGG)**2
32724 DO 150 I=MMINA,MMAXA
32725 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
32726 EI=KCHG(IABS(I),1)/3D0
32730 IF(IABS(I).LE.10) FCOI=FACA/3D0
32735 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
32738 ELSEIF(ISUB.EQ.26) THEN
32739 C...f + fbar' -> W+/- + h0 (or H0, or A0)
32740 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
32741 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32742 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32743 GMMW3=SQRT(SQM3)*WDTP(0)
32744 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32745 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32746 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32747 GMMH4=SQRT(SQM4)*WDTP(0)
32748 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32749 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32750 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
32751 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
32752 FACHW=FACHW*WIDS(KFHIGG,2)
32753 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
32754 & PARU(155+10*IHIGG)**2
32755 DO 170 I=MMIN1,MMAX1
32757 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
32758 DO 160 J=MMIN2,MMAX2
32760 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
32761 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
32762 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32764 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32766 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32768 IF(IA.LE.10) FCOI=FACA/3D0
32773 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
32777 ELSEIF(ISUB.EQ.32) THEN
32778 C...f + g -> f + h0 (q + g -> q + h0 only)
32779 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
32780 C...H propagator: as simulated in PYOFSH and as desired
32781 SQMHC=PMAS(25,1)**2
32782 GMMHC=PMAS(25,1)*PMAS(25,2)
32783 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32784 CALL PYWIDT(25,SQM4,WDTP,WDTE)
32785 GMMHCC=SQRT(SQM4)*WDTP(0)
32786 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32787 FHCQ=FHCQ*HBW4C/HBW4
32788 DO 190 I=MMINA,MMAXA
32790 IF(IA.NE.5) GOTO 190
32791 SQML=PYMRUN(IA,SH)**2
32793 FACHCQ=FHCQ*SQML/SQMW*
32794 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32795 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
32796 & (SQM4-SQMQ-SH)/SH)
32798 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
32799 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
32802 ISIG(NCHN,3-ISDE)=21
32804 SIGH(NCHN)=FACHCQ*WIDS(25,2)
32809 ELSEIF(ISUB.LE.80) THEN
32810 IF(ISUB.EQ.71) THEN
32811 C...Z0 + Z0 -> Z0 + Z0
32812 IF(SH.LE.4.01D0*SQMZ) GOTO 220
32814 IF(MSTP(46).LE.2) THEN
32815 C...Exact scattering ME:s for on-mass-shell gauge bosons
32816 BE2=1D0-4D0*SQMZ/SH
32817 TH=-0.5D0*SH*BE2*(1D0-CTH)
32818 UH=-0.5D0*SH*BE2*(1D0+CTH)
32819 IF(MAX(TH,UH).GT.-1D0) GOTO 220
32820 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
32821 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32822 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32823 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
32824 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32825 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32826 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
32827 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32828 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32829 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32830 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32831 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32832 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
32833 & (ASHIM+ATHIM+AUHIM)**2)
32834 IF(MSTP(46).EQ.2) FACZZ=0D0
32837 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32838 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32839 & ABS(A00U+2D0*A20U)**2
32841 FACZZ=FACZZ*WIDS(23,1)
32843 DO 210 I=MMIN1,MMAX1
32844 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
32845 EI=KCHG(IABS(I),1)/3D0
32849 DO 200 J=MMIN2,MMAX2
32850 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
32851 EJ=KCHG(IABS(J),1)/3D0
32859 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
32864 ELSEIF(ISUB.EQ.72) THEN
32865 C...Z0 + Z0 -> W+ + W-
32866 IF(SH.LE.4.01D0*SQMZ) GOTO 250
32868 IF(MSTP(46).LE.2) THEN
32869 C...Exact scattering ME:s for on-mass-shell gauge bosons
32870 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32872 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32873 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32874 IF(MAX(TH,UH).GT.-1D0) GOTO 250
32875 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32876 & (1D0-2D0*SQMZ/SH)
32877 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32878 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32879 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32880 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32881 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32882 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32883 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32885 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32886 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32887 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32888 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32889 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32891 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32893 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32894 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32895 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
32896 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32897 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32898 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
32899 & (ATWIM+AUWIM+A4IM)**2)
32902 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32903 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32904 & ABS(A00U-A20U)**2
32906 FACWW=FACWW*WIDS(24,1)
32908 DO 240 I=MMIN1,MMAX1
32909 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32910 EI=KCHG(IABS(I),1)/3D0
32914 DO 230 J=MMIN2,MMAX2
32915 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32916 EJ=KCHG(IABS(J),1)/3D0
32924 SIGH(NCHN)=FACWW*AVI*AVJ
32929 ELSEIF(ISUB.EQ.73) THEN
32930 C...Z0 + W+/- -> Z0 + W+/-
32931 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32933 IF(MSTP(46).LE.2) THEN
32934 C...Exact scattering ME:s for on-mass-shell gauge bosons
32935 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32936 EP1=1D0-(SQMZ-SQMW)/SH
32937 EP2=1D0+(SQMZ-SQMW)/SH
32938 TH=-0.5D0*SH*BE2*(1D0-CTH)
32939 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32940 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32941 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32942 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32943 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32944 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32945 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32946 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32947 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32949 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32950 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32951 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32952 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32953 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32954 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32955 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32956 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32957 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32958 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32959 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32960 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32962 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32963 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32965 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32966 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32967 IF(MSTP(46).LE.0) FACZW=0D0
32968 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32969 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32970 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32971 & (ASWIM+AUWIM+A4IM)**2)
32974 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32975 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32976 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32978 FACZW=FACZW*WIDS(23,2)
32980 DO 270 I=MMIN1,MMAX1
32981 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
32982 EI=KCHG(IABS(I),1)/3D0
32986 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
32987 DO 260 J=MMIN2,MMAX2
32988 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
32989 EJ=KCHG(IABS(J),1)/3D0
32993 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
32998 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33003 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33008 ELSEIF(ISUB.EQ.75) THEN
33009 C...W+ + W- -> gamma + gamma
33011 ELSEIF(ISUB.EQ.76) THEN
33012 C...W+ + W- -> Z0 + Z0
33013 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33015 IF(MSTP(46).LE.2) THEN
33016 C...Exact scattering ME:s for on-mass-shell gauge bosons
33017 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33019 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33020 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33021 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33022 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33023 & (1D0-2D0*SQMZ/SH)
33024 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33025 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33026 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33027 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33028 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33029 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33030 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33032 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33033 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33034 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33035 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33036 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33038 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33040 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33042 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33043 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33044 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33045 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33046 & (ATWIM+AUWIM+A4IM)**2)
33049 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33050 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33051 & ABS(A00U-A20U)**2
33053 FACZZ=FACZZ*WIDS(23,1)
33055 DO 300 I=MMIN1,MMAX1
33056 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33057 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33058 DO 290 J=MMIN2,MMAX2
33059 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33060 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33061 IF(EI*EJ.GT.0D0) GOTO 290
33066 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33071 ELSEIF(ISUB.EQ.77) THEN
33072 C...W+/- + W+/- -> W+/- + W+/-
33073 IF(SH.LE.4.01D0*SQMW) GOTO 340
33075 IF(MSTP(46).LE.2) THEN
33076 C...Exact scattering ME:s for on-mass-shell gauge bosons
33077 BE2=1D0-4D0*SQMW/SH
33081 TH=-0.5D0*SH*BE2*(1D0-CTH)
33082 UH=-0.5D0*SH*BE2*(1D0+CTH)
33083 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33085 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33086 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33088 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33089 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33091 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33092 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33093 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33096 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33098 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33099 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33100 ATGRE=0.5D0*XW*SH/TH*TGZANG
33102 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33104 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33105 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33106 AUGRE=0.5D0*XW*SH/UH*UGZANG
33108 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33110 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33112 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33114 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33116 IF(MSTP(46).LE.0) THEN
33121 ELSEIF(MSTP(46).EQ.1) THEN
33122 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33123 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33124 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33125 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33127 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33128 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33129 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33130 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33132 AWWA2=AWWARE**2+AWWAIM**2
33133 AWWS2=AWWSRE**2+AWWSIM**2
33136 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33137 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33138 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
33139 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
33142 DO 330 I=MMIN1,MMAX1
33143 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
33144 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33145 DO 320 J=MMIN2,MMAX2
33146 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
33147 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33148 IF(EI*EJ.LT.0D0) THEN
33150 IF(MSTP(45).EQ.1) GOTO 320
33151 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
33152 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
33155 IF(MSTP(45).EQ.2) GOTO 320
33156 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
33157 IF(MSTP(46).GE.3) FACWW=FWWS
33158 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
33159 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
33165 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
33166 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
33172 ELSEIF(ISUB.LE.120) THEN
33173 IF(ISUB.EQ.102) THEN
33174 C...g + g -> h0 (or H0, or A0)
33175 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33177 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33178 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33179 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33181 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33182 & '(PYSGHG:) did not find Higgs -> g g channel')
33184 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33185 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33186 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33189 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
33194 SIGH(NCHN)=HI*FACBW*HF
33197 ELSEIF(ISUB.EQ.103) THEN
33198 C...gamma + gamma -> h0 (or H0, or A0)
33199 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33201 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33202 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
33203 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
33205 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
33206 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33208 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33209 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33210 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33213 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
33218 SIGH(NCHN)=HI*FACBW*HF
33221 ELSEIF(ISUB.EQ.110) THEN
33222 C...f + fbar -> gamma + h0
33223 THUH=MAX(TH*UH,SH*CKIN(3)**2)
33224 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
33225 FACHG=FACHG*WIDS(KFHIGG,2)
33226 C...Calculate loop contributions for intermediate gamma* and Z0
33227 CIGTOT=DCMPLX(0D0,0D0)
33228 CIZTOT=DCMPLX(0D0,0D0)
33231 IF(J.LE.2*MSTP(1)) THEN
33234 AJ=SIGN(1D0,EJ+0.1D0)
33236 BALP=SQM4/(2D0*PMAS(J,1))**2
33237 BBET=SH/(2D0*PMAS(J,1))**2
33238 ELSEIF(J.LE.3*MSTP(1)) THEN
33240 JL=2*(J-2*MSTP(1))-1
33241 EJ=KCHG(10+JL,1)/3D0
33242 AJ=SIGN(1D0,EJ+0.1D0)
33244 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
33245 BBET=SH/(2D0*PMAS(10+JL,1))**2
33247 BALP=SQM4/(2D0*PMAS(24,1))**2
33248 BBET=SH/(2D0*PMAS(24,1))**2
33250 BABI=1D0/(BALP-BBET)
33251 IF(BALP.LT.1D0) THEN
33252 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
33255 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
33256 & -DBLE(0.5D0*PARU(1)))
33259 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
33260 IF(BBET.LT.1D0) THEN
33261 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
33264 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
33265 & -DBLE(0.5D0*PARU(1)))
33268 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
33269 IF(J.LE.3*MSTP(1)) THEN
33270 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
33271 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
33272 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
33273 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
33276 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
33277 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
33278 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
33279 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
33280 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
33281 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
33285 CIGTOT=CIGTOT/DBLE(SH)
33286 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
33287 C...Loop over initial flavours
33288 DO 380 I=MMINA,MMAXA
33289 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
33290 EI=KCHG(IABS(I),1)/3D0
33294 IF(IABS(I).LE.10) FCOI=FACA/3D0
33299 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
33300 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
33303 ELSEIF(ISUB.EQ.111) THEN
33304 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
33305 IF(MSTP(38).NE.0) THEN
33306 C...Simple case: only do gg <-> h exactly.
33307 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33309 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33310 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33311 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33313 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33314 & '(PYSGHG:) did not find Higgs -> g g channel')
33315 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
33316 & (TH**2+UH**2)/(SH*SQM4)
33317 C...Propagators: as simulated in PYOFSH and as desired
33318 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33319 GMMHC=SQRT(SQM4)*WDTP(0)
33320 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33321 & ((SQM4-SQMH)**2+GMMHC**2)
33322 FACGH=FACGH*HBW4C/HBW4
33324 C...Messy case: do full loop integrals
33327 DO 390 I=1,2*MSTP(1)
33331 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33332 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33333 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33334 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33335 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
33336 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
33337 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
33338 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
33340 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33341 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
33342 FACGH=FACGH*WIDS(25,2)
33344 DO 400 I=MMINA,MMAXA
33345 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33346 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33354 ELSEIF(ISUB.EQ.112) THEN
33355 C...f + g -> f + h0 (q + g -> q + h0 only)
33356 IF(MSTP(38).NE.0) THEN
33357 C...Simple case: only do gg <-> h exactly.
33358 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33360 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33361 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33362 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33364 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33365 & '(PYSGHG:) did not find Higgs -> g g channel')
33366 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
33367 & (SH**2+UH**2)/(-TH*SQM4)
33368 C...Propagators: as simulated in PYOFSH and as desired
33369 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33370 GMMHC=SQRT(SQM4)*WDTP(0)
33371 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33372 & ((SQM4-SQMH)**2+GMMHC**2)
33373 FACQH=FACQH*HBW4C/HBW4
33375 C...Messy case: do full loop integrals
33378 DO 410 I=1,2*MSTP(1)
33382 CALL PYWAUX(1,EPST,W1TR,W1TI)
33383 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33384 CALL PYWAUX(2,EPST,W2TR,W2TI)
33385 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33386 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
33387 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
33388 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
33389 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
33391 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33392 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
33393 FACQH=FACQH*WIDS(25,2)
33395 DO 430 I=MMINA,MMAXA
33396 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
33398 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
33399 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
33402 ISIG(NCHN,3-ISDE)=21
33408 ELSEIF(ISUB.EQ.113) THEN
33409 C...g + g -> g + h0
33410 IF(MSTP(38).NE.0) THEN
33411 C...Simple case: only do gg <-> h exactly.
33412 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33414 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33415 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33416 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33418 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33419 & '(PYSGHG:) did not find Higgs -> g g channel')
33420 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
33421 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
33422 C...Propagators: as simulated in PYOFSH and as desired
33423 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33424 GMMHC=SQRT(SQM4)*WDTP(0)
33425 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33426 & ((SQM4-SQMH)**2+GMMHC**2)
33427 FACGH=FACGH*HBW4C/HBW4
33429 C...Messy case: do full loop integrals
33438 DO 440 I=1,2*MSTP(1)
33444 IF(EPSH.LT.1D-6) GOTO 440
33445 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33446 CALL PYWAUX(1,EPST,W1TR,W1TI)
33447 CALL PYWAUX(1,EPSU,W1UR,W1UI)
33448 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33449 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33450 CALL PYWAUX(2,EPST,W2TR,W2TI)
33451 CALL PYWAUX(2,EPSU,W2UR,W2UI)
33452 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33453 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
33454 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
33455 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
33456 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
33457 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
33458 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
33459 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
33460 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
33461 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
33462 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
33463 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
33464 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
33465 W3STUR=YHSTUR-Y3STUR-Y3UTSR
33466 W3STUI=YHSTUI-Y3STUI-Y3UTSI
33467 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
33468 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
33469 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
33470 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
33471 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
33472 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
33473 W3USTR=YHUSTR-Y3USTR-Y3TSUR
33474 W3USTI=YHUSTI-Y3USTI-Y3TSUI
33475 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
33476 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
33477 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
33478 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
33479 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
33480 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
33481 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
33482 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
33483 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
33484 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
33485 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
33486 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
33487 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
33488 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
33489 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
33490 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
33491 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
33492 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
33493 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
33494 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
33495 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
33496 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
33497 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
33498 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
33499 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
33500 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
33501 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
33502 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
33503 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
33504 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
33505 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
33506 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
33507 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
33508 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
33509 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
33510 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
33511 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
33512 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
33513 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
33514 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
33515 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
33516 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
33517 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
33518 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
33519 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
33520 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
33521 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
33522 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
33523 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
33524 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
33525 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
33526 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
33527 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
33528 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
33529 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
33530 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
33531 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
33532 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
33533 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
33534 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
33535 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
33536 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
33537 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33538 & (W2SR-W2HR+W3STUR))
33539 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
33540 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33541 & (W2TR-W2HR+W3TUSR))
33542 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
33543 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33544 & (W2UR-W2HR+W3USTR))
33545 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
33546 A2STUR=A2STUR+B2STUR+B2SUTR
33547 A2STUI=A2STUI+B2STUI+B2SUTI
33548 A2USTR=A2USTR+B2USTR+B2UTSR
33549 A2USTI=A2USTI+B2USTI+B2UTSI
33550 A2TUSR=A2TUSR+B2TUSR+B2TSUR
33551 A2TUSI=A2TUSI+B2TUSI+B2TSUI
33552 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
33553 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
33555 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
33556 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
33557 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
33558 FACGH=FACGH*WIDS(25,2)
33560 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
33569 ELSEIF(ISUB.LE.170) THEN
33570 IF(ISUB.EQ.121) THEN
33571 C...g + g -> Q + Qbar + h0
33572 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
33575 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33576 & (0.5D0*PMF/PMAS(24,1))**2
33578 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33580 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33582 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33583 IF(IA.GT.10) IKFI=3
33584 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33585 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33586 FACQQH=FACQQH/(1D0+RMSS(41))**2
33587 IF(IHIGG.NE.3) THEN
33588 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33589 & PARU(151+10*IHIGG))**2
33593 CALL PYQQBH(WTQQBH)
33594 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33596 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33597 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33598 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33604 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33607 ELSEIF(ISUB.EQ.122) THEN
33608 C...q + qbar -> Q + Qbar + h0
33611 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33612 & (0.5D0*PMF/PMAS(24,1))**2
33614 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33616 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33618 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33619 IF(IA.GT.10) IKFI=3
33620 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33621 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33622 FACQQH=FACQQH/(1D0+RMSS(41))**2
33623 IF(IHIGG.NE.3) THEN
33624 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33625 & PARU(151+10*IHIGG))**2
33629 CALL PYQQBH(WTQQBH)
33630 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33632 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33633 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33634 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33636 DO 470 I=MMINA,MMAXA
33637 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33638 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
33643 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33646 ELSEIF(ISUB.EQ.123) THEN
33647 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
33649 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
33650 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33651 & PARU(154+10*IHIGG)**2
33652 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33653 & (VINT(216)-VINT(209)**2))**2
33654 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33655 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
33656 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33658 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33659 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33660 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33662 DO 490 I=MMIN1,MMAX1
33663 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
33665 DO 480 J=MMIN2,MMAX2
33666 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
33668 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
33669 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
33671 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
33672 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
33674 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
33675 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
33680 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
33684 ELSEIF(ISUB.EQ.124) THEN
33685 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
33687 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
33688 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33689 & PARU(155+10*IHIGG)**2
33690 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33691 & (VINT(216)-VINT(209)**2))**2
33692 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33693 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33695 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33696 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33697 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33699 DO 510 I=MMIN1,MMAX1
33700 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
33701 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33702 DO 500 J=MMIN2,MMAX2
33703 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
33704 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33705 IF(EI*EJ.GT.0D0) GOTO 500
33706 FACLR=VINT(180+I)*VINT(180+J)
33711 SIGH(NCHN)=FACLR*FACWW*FACBW
33715 ELSEIF(ISUB.EQ.143) THEN
33716 C...f + fbar' -> H+/-
33717 SQMHC=PMAS(37,1)**2
33718 CALL PYWIDT(37,SH,WDTP,WDTE)
33720 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
33721 HP=AEM/(8D0*XW)*SH/SQMW*SH
33722 DO 530 I=MMIN1,MMAX1
33723 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
33725 IM=(MOD(IA,10)+1)/2
33726 DO 520 J=MMIN2,MMAX2
33727 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
33729 JM=(MOD(JA,10)+1)/2
33730 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
33731 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33733 IF(MOD(IA,2).EQ.0) THEN
33740 RML=PYMRUN(IL,SH)**2/SH
33741 RMU=PYMRUN(IU,SH)**2/SH
33742 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
33743 IF(IA.LE.10) HI=HI*FACA/3D0
33744 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33745 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
33750 SIGH(NCHN)=HI*FACBW*HF
33754 ELSEIF(ISUB.EQ.161) THEN
33755 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
33756 C...(choice of only b and t to avoid kinematics problems)
33757 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
33758 C...H propagator: as simulated in PYOFSH and as desired
33759 SQMHC=PMAS(37,1)**2
33760 GMMHC=PMAS(37,1)*PMAS(37,2)
33761 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33762 CALL PYWIDT(37,SQM4,WDTP,WDTE)
33763 GMMHCC=SQRT(SQM4)*WDTP(0)
33764 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33765 FHCQ=FHCQ*HBW4C/HBW4
33767 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
33768 DO 550 I=MMINA,MMAXA
33770 IF(IA.NE.5) GOTO 550
33771 SQML=PYMRUN(IA,Q2RM)**2
33773 SQMQ=PYMRUN(IUA,Q2RM)**2
33774 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
33775 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33776 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
33777 & (SQMHC-SQMQ-SH)/SH)
33778 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33780 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
33781 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
33784 ISIG(NCHN,3-ISDE)=21
33786 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
33787 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
33792 ELSEIF(ISUB.LE.402) THEN
33793 IF(ISUB.EQ.401) THEN
33794 C... g + g -> t + bbar + H-
33795 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
33798 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33800 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33801 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33807 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33808 c Since we don't know yet if H+ or H-, assume H+
33809 c when calculating suppression due to closed channels.
33810 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33811 IF(ABS(WIDS(37,2)-WIDS(37,3))
33812 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
33813 & ABS(WIDS(6,2)-WIDS(6,3))
33814 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
33815 WRITE(*,*)'Error: Process 401 cannot handle different'
33816 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33817 WRITE(*,*)'Execution stopped.'
33822 ELSEIF(ISUB.EQ.402) THEN
33823 C... q + qbar -> t + bbar + H-
33826 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33828 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33829 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33831 DO 570 I=MMINA,MMAXA
33832 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33833 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
33838 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33839 c Since we don't know yet if H+ or H-, assume H+
33840 c when calculating suppression due to closed channels.
33841 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33842 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
33844 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
33846 WRITE(*,*)'Error: Process 402 cannot handle different'
33847 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33848 WRITE(*,*)'Execution stopped.'
33858 C*********************************************************************
33861 C...Subprocess cross sections for SUSY processes,
33862 C...including Higgs pair production.
33863 C...Auxiliary to PYSIGH.
33865 SUBROUTINE PYSGSU(NCHN,SIGS)
33867 C...Double precision and integer declarations
33868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33869 IMPLICIT INTEGER(I-N)
33870 INTEGER PYK,PYCHGE,PYCOMP
33871 C...Parameter statement to help give large particle numbers.
33872 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33873 &KEXCIT=4000000,KDIMEN=5000000)
33875 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33876 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33877 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33878 COMMON/PYINT1/MINT(400),VINT(400)
33879 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33880 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33881 COMMON/PYINT4/MWID(500),WIDS(500,5)
33882 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33883 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33884 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33885 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33886 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33887 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33888 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33889 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
33890 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
33891 C...Local arrays and complex variables
33892 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33893 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
33894 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
33895 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
33898 C...Z and W width, combinations of weak mixing angle
33902 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33904 C...Convert almost equivalent SUSY processes into each other
33905 C...Extract differences in flavours and couplings
33907 C...Sleptons and sneutrinos
33908 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33909 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33912 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33913 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33916 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33917 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33919 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33920 IF(ISUB.EQ.210) THEN
33922 ELSEIF(ISUB.EQ.211) THEN
33924 ELSEIF(ISUB.EQ.212) THEN
33928 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33929 IF(ISUB.EQ.213) THEN
33930 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33932 ELSEIF(ISUB.EQ.214) THEN
33939 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33940 IF(ISUB.EQ.216) THEN
33943 ELSEIF(ISUB.EQ.217) THEN
33946 ELSEIF(ISUB.EQ.218) THEN
33949 ELSEIF(ISUB.EQ.219) THEN
33952 ELSEIF(ISUB.EQ.220) THEN
33955 ELSEIF(ISUB.EQ.221) THEN
33958 ELSEIF(ISUB.EQ.222) THEN
33961 ELSEIF(ISUB.EQ.223) THEN
33964 ELSEIF(ISUB.EQ.224) THEN
33967 ELSEIF(ISUB.EQ.225) THEN
33974 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33975 IF(ISUB.EQ.226) THEN
33978 ELSEIF(ISUB.EQ.227) THEN
33981 ELSEIF(ISUB.EQ.228) THEN
33987 C...Neutralino + chargino
33988 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
33989 IF(ISUB.EQ.229) THEN
33992 ELSEIF(ISUB.EQ.230) THEN
33995 ELSEIF(ISUB.EQ.231) THEN
33998 ELSEIF(ISUB.EQ.232) THEN
34001 ELSEIF(ISUB.EQ.233) THEN
34004 ELSEIF(ISUB.EQ.234) THEN
34007 ELSEIF(ISUB.EQ.235) THEN
34010 ELSEIF(ISUB.EQ.236) THEN
34016 C...Gluino + neutralino
34017 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34018 IF(ISUB.EQ.237) THEN
34020 ELSEIF(ISUB.EQ.238) THEN
34022 ELSEIF(ISUB.EQ.239) THEN
34024 ELSEIF(ISUB.EQ.240) THEN
34029 C...Gluino + chargino
34030 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34031 IF(ISUB.EQ.241) THEN
34033 ELSEIF(ISUB.EQ.242) THEN
34038 C...Squark + neutralino
34039 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34041 IF(MOD(ISUB,2).NE.0) ILR=1
34042 IF(ISUB.LE.247) THEN
34044 ELSEIF(ISUB.LE.249) THEN
34046 ELSEIF(ISUB.LE.251) THEN
34048 ELSEIF(ISUB.LE.253) THEN
34054 C...Squark + chargino
34055 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34056 IF(ISUB.LE.255) THEN
34058 ELSEIF(ISUB.LE.257) THEN
34061 IF(MOD(ISUB,2).EQ.0) THEN
34069 C...Squark + gluino
34070 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34075 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34077 IF(ISUB.EQ.262) ILR=1
34079 ELSEIF(ISUB.EQ.265) THEN
34083 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34085 IF(ISUB.LE.273) THEN
34086 IF(ISUB.EQ.273) ILR=1
34089 ELSEIF(ISUB.LE.276) THEN
34090 IF(ISUB.EQ.276) ILR=1
34093 ELSEIF(ISUB.LE.278) THEN
34094 IF(ISUB.EQ.278) ILR=1
34098 IF(ISUB.EQ.280) ILR=1
34103 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34105 IF(ISUB.LE.283) THEN
34106 IF(ISUB.EQ.283) ILR=1
34109 ELSEIF(ISUB.LE.286) THEN
34110 IF(ISUB.EQ.286) ILR=1
34113 ELSEIF(ISUB.LE.288) THEN
34114 IF(ISUB.EQ.288) ILR=1
34117 ELSEIF(ISUB.LE.290) THEN
34118 IF(ISUB.EQ.290) ILR=1
34121 ELSEIF(ISUB.LE.293) THEN
34122 IF(ISUB.EQ.293) ILR=1
34125 ELSEIF(ISUB.EQ.296) THEN
34129 C...Squark + gluino
34130 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
34135 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
34136 IF(ISUB.EQ.297) THEN
34137 RKF=.5D0*PARU(195)**2
34138 ELSEIF(ISUB.EQ.298) THEN
34139 RKF=.5D0*(1D0-PARU(195)**2)
34143 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
34144 IF(ISUB.EQ.299) THEN
34147 ELSEIF(ISUB.EQ.300) THEN
34153 ELSEIF(ISUB.EQ.301) THEN
34159 C...Supersymmetric processes - all of type 2 -> 2 :
34160 C...correct final-state Breit-Wigners from fixed to running width.
34161 IF(MSTP(42).GT.0) THEN
34163 KFLW=KFPR(ISUBSV,I)
34165 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
34166 IF(I.EQ.1) SQMI=SQM3
34167 IF(I.EQ.2) SQMI=SQM4
34168 SQMS=PMAS(KCW,1)**2
34169 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
34170 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
34171 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
34172 GMMI=SQRT(SQMI)*WDTP(0)
34173 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
34174 COMFAC=COMFAC*(HBWI/HBWS)
34178 C...Differential cross section expressions.
34180 IF(ISUB.LE.210) THEN
34181 IF(ISUB.EQ.201) THEN
34182 C...f + fbar -> e_L + e_Lbar
34183 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34184 DO 130 I=MMIN1,MMAX1
34186 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
34188 TT3I=SIGN(1D0,EI+1D-6)/2D0
34192 C...Color factor for e+ e-
34193 IF(IA.GE.11) FCOL=3D0
34194 IF(ISUBSV.EQ.301) THEN
34197 ELSEIF(ILR.EQ.1) THEN
34198 A1=SFMIX(KFID,3)**2
34199 A2=SFMIX(KFID,4)**2
34200 ELSEIF(ILR.EQ.0) THEN
34201 A1=SFMIX(KFID,1)**2
34202 A2=SFMIX(KFID,2)**2
34204 XLQ=(TT3J-EJ*XW)*A1
34208 TAA=(EI*EJ)**2*(POLL+POLR)
34209 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
34210 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
34211 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
34212 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34216 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34222 DK=1D0/(TH-SMZ(II)**2)
34223 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34225 FREK=FAC2*TANW*EI*ZMIX(II,1)
34226 TNN1=TNN1+FLEK**2*DK
34227 TNN2=TNN2+FREK**2*DK
34229 DL=1D0/(TH-SMZ(JJ)**2)
34230 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34232 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34233 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34236 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
34237 & A2**2*TNN2**2*POLR)
34238 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
34239 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
34240 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
34241 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
34242 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34245 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
34248 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
34249 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
34250 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
34255 SIGH(NCHN)=FACQQ1+FACQQ2
34258 ELSEIF(ISUB.EQ.203) THEN
34259 C...f + fbar -> e_L + e_Rbar
34260 DO 160 I=MMIN1,MMAX1
34262 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
34263 EI=KCHG(IABS(I),1)/3D0
34264 TT3I=SIGN(1D0,EI)/2D0
34268 C...Color factor for e+ e-
34269 IF(IA.GE.11) FCOL=3D0
34270 A1=SFMIX(KFID,1)**2
34271 A2=SFMIX(KFID,2)**2
34276 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
34277 & /XW**2/XW1**2*A1*A2
34278 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34283 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34289 DK=1D0/(TH-SMZ(II)**2)
34290 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34292 FREK=FAC2*TANW*EI*ZMIX(II,1)
34293 TNN1=TNN1+FLEK**2*DK
34294 TNN2=TNN2+FREK**2*DK
34296 DL=1D0/(TH-SMZ(JJ)**2)
34297 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34299 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34300 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34303 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
34304 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
34305 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
34306 TZN=(UH*TH-SQM3*SQM4)*A1*A2
34307 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
34308 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34311 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
34312 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
34313 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
34319 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34320 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34325 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34326 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34329 ELSEIF(ISUB.EQ.210) THEN
34330 C...q + qbar' -> W*- > ~l_L + ~nu_L
34331 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
34332 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
34333 DO 180 I=MMIN1,MMAX1
34335 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
34336 DO 170 J=MMIN2,MMAX2
34338 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
34339 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
34341 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34342 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34344 IF(KCHSUM.LT.0) KCHW=3
34349 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
34350 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34351 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34353 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34354 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34356 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
34361 ELSEIF(ISUB.LE.220) THEN
34362 IF(ISUB.EQ.213) THEN
34363 C...f + fbar -> ~nu_L + ~nu_Lbar
34364 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
34365 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34366 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34368 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34371 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
34374 DO 190 I=MMIN1,MMAX1
34376 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
34379 C...Color factor for e+ e-
34380 IF(IA.GE.11) FCOL=3D0
34381 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
34385 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
34386 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
34389 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
34391 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
34397 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
34398 & *AEM**2*FCOL/3D0/XW**2
34401 ELSEIF(ISUB.EQ.216) THEN
34402 C...q + qbar -> ~chi0_1 + ~chi0_1
34403 IF(IZID1.EQ.IZID2) THEN
34404 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34406 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34407 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34409 FACXX=COMFAC*AEM**2/3D0/XW**2
34410 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
34413 WU2 = (UH-ZM12)*(UH-ZM22)
34414 WT2 = (TH-ZM12)*(TH-ZM22)
34415 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
34416 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34417 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34419 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
34420 IF(IZID2.NE.IZID1) THEN
34421 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34424 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
34425 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
34427 DO 210 I=MMINA,MMAXA
34428 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
34429 EI=KCHG(IABS(I),1)/3D0
34430 T3I=SIGN(1D0,EI+1D-6)/2D0
34431 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
34432 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
34433 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
34434 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
34435 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
34436 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
34437 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
34439 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
34440 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
34441 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
34443 IF(IABS(I).GE.11) FCOL=3D0
34444 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34445 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34446 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34447 & QRL*DCONJG(QRR)*POLR)*WS2
34452 SIGH(NCHN)=FACXX*FACGG1*FCOL
34456 ELSEIF(ISUB.LE.230) THEN
34457 IF(ISUB.EQ.226) THEN
34458 C...f + fbar -> ~chi+_1 + ~chi-_1
34459 FACXX=COMFAC*AEM**2/3D0
34462 WU2 = (UH-ZM12)*(UH-ZM22)
34463 WT2 = (TH-ZM12)*(TH-ZM22)
34464 WS2 = SMW(IZID1)*SMW(IZID2)*SH
34465 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34466 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34468 IF(IZID1.EQ.IZID2) DIFF=1D0
34470 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34471 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34472 IF(IZID2.NE.IZID1) THEN
34473 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
34474 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
34477 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
34478 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
34479 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
34480 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
34481 DO 230 I=MMINA,MMAXA
34482 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
34483 EI=KCHG(IABS(I),1)/3D0
34484 T3I=SIGN(1D0,EI+1D-6)/2D0
34485 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
34486 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
34487 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
34488 IF(MOD(I,2).EQ.0) THEN
34489 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
34490 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34491 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
34492 & DCMPLX(T3I/XW/(TH-XML2))
34494 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
34495 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34496 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
34497 & DCMPLX(T3I/XW/(TH-XML2))
34500 IF(IABS(I).GE.11) FCOL=3D0
34501 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34502 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34503 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34504 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
34509 IF(IZID1.EQ.IZID2) THEN
34510 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34512 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34513 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34518 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34519 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34523 ELSEIF(ISUB.EQ.229) THEN
34524 C...q + qbar' -> ~chi0_1 + ~chi+-_1
34525 FACXX=COMFAC*AEM**2/6D0/XW**2
34528 WU2 = (UH-ZM12)*(UH-ZM22)
34529 WT2 = (TH-ZM12)*(TH-ZM22)
34530 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
34531 RT2I = 1D0/SQRT(2D0)
34532 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
34533 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
34535 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34536 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34539 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34541 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
34542 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
34543 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
34544 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
34546 DO 270 I=MMIN1,MMAX1
34548 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
34550 T3I=SIGN(1D0,EI+1D-6)/2D0
34551 DO 260 J=MMIN2,MMAX2
34553 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
34554 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
34556 T3J=SIGN(1D0,EJ+1D-6)/2D0
34558 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34559 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34561 IF(KCHSUM.LT.0) KCHW=3
34562 IF(MOD(IA,2).EQ.0) THEN
34563 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34564 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34565 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
34566 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
34567 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34568 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
34571 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34572 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34573 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
34574 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
34575 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34576 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
34579 ZINTR=DBLE(QLR*DCONJG(QLL))
34580 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
34586 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34587 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34592 ELSEIF(ISUB.LE.240) THEN
34593 IF(ISUB.EQ.237) THEN
34594 C...q + qbar -> gluino + ~chi0_1
34595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34596 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34598 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
34601 DO 280 I=MMINA,MMAXA
34602 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
34603 EI=KCHG(IABS(I),1)/3D0
34605 XLQC = -TANW*EI*ZMIX(IZID,1)
34606 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34607 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34610 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
34611 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
34612 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
34613 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
34614 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
34615 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34616 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
34617 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
34618 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
34619 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34624 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
34628 ELSEIF(ISUB.LE.250) THEN
34629 IF(ISUB.EQ.241) THEN
34630 C...q + qbar' -> ~chi+-_1 + gluino
34631 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
34634 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
34635 FAC0=UMIX(IZID,1)**2
34636 FAC1=VMIX(IZID,1)**2
34637 DO 300 I=MMIN1,MMAX1
34639 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
34640 DO 290 J=MMIN2,MMAX2
34642 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
34643 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
34645 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34646 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34648 IF(KCHSUM.LT.0) KCHW=3
34649 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
34650 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
34651 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
34652 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
34653 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
34654 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
34655 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
34656 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
34657 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
34658 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
34659 & SH/(TH-XMU2)/(UH-XMD2))/2D0
34664 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
34665 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34666 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34670 ELSEIF(ISUB.EQ.243) THEN
34671 C...q + qbar -> gluino + gluino
34672 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34675 DO 310 I=MMINA,MMAXA
34676 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34677 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
34679 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
34680 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
34681 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34682 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34683 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34684 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34685 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
34686 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
34687 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34688 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34689 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34690 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34694 C...1/2 for identical particles
34695 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
34698 ELSEIF(ISUB.EQ.244) THEN
34699 C...g + g -> gluino + gluino
34700 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34703 FACQQ1=COMFAC*AS**2*9D0/4D0*(
34704 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
34705 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
34706 FACQQ2=COMFAC*AS**2*9D0/4D0*(
34707 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
34708 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
34709 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
34710 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
34711 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
34716 SIGH(NCHN)=FACQQ1/2D0
34721 SIGH(NCHN)=FACQQ2/2D0
34726 SIGH(NCHN)=FACQQ3/2D0
34729 ELSEIF(ISUB.EQ.246) THEN
34730 C...g + q_j -> ~chi0_1 + ~q_j
34731 FAC0=COMFAC*AS*AEM/6D0/XW
34734 FACZQ0=FAC0*( (ZM2-TH)/SH +
34735 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34736 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34737 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34738 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
34739 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
34740 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
34741 EI=KCHG(IABS(I),1)/3D0
34743 XRQZ = -TANW*EI*ZMIX(IZID,1)
34744 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34745 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34747 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
34749 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
34755 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
34756 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
34759 ISIG(NCHN,3-ISDE)=21
34761 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34762 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34767 ELSEIF(ISUB.LE.260) THEN
34768 IF(ISUB.EQ.254) THEN
34769 C...g + q_j -> ~chi1_1 + ~q_i
34770 FAC0=COMFAC*AS*AEM/12D0/XW
34775 FACZQ0=FAC0*( (ZM2-TH)/SH +
34776 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34777 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34778 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
34779 IF(MOD(KFNSQ1,2).EQ.0) THEN
34786 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
34787 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
34788 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
34790 IF(MOD(IA,2).EQ.0) THEN
34795 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
34799 IF(I.LT.0) KCHWQ=5-KCHW
34801 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
34802 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
34805 ISIG(NCHN,3-ISDE)=21
34807 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34808 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
34812 ELSEIF(ISUB.EQ.258) THEN
34813 C...g + q_j -> gluino + ~q_i
34820 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
34821 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
34822 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
34823 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
34824 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
34826 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
34827 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
34828 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
34830 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
34831 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
34832 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34833 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
34834 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
34835 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
34838 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34839 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34841 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
34842 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
34845 ISIG(NCHN,3-ISDE)=21
34847 SIGH(NCHN)=FACQG1*FACSEL
34850 ISIG(NCHN,3-ISDE)=21
34852 SIGH(NCHN)=FACQG2*FACSEL
34857 ELSEIF(ISUB.LE.270) THEN
34858 IF(ISUB.EQ.261) THEN
34859 C...q_i + q_ibar -> ~t_1 + ~t_1bar
34860 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
34861 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34862 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34864 DO 390 I=MMIN1,MMAX1
34866 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
34867 IF(IA.GE.11.AND.IA.LE.18) THEN
34869 EJ=KCHG(KFNSQ,1)/3D0
34870 T3I=SIGN(1D0,EI)/2D0
34871 T3J=SIGN(1D0,EJ)/2D0
34872 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
34873 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
34874 XLF=2D0*(T3I-EI*XW)
34876 TAA=0.5D0*(EI*EJ)**2
34877 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34878 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34879 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34880 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34881 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34887 SIGH(NCHN)=FACQQ1*FAC0
34890 ELSEIF(ISUB.EQ.263) THEN
34891 C...f + fbar -> ~t1 + ~t2bar
34892 DO 400 I=MMIN1,MMAX1
34894 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34895 EI=KCHG(IABS(I),1)/3D0
34896 TT3I=SIGN(1D0,EI)/2D0
34900 C...Color factor for e+ e-
34901 IF(IA.GE.11) FCOL=3D0
34902 XLQ=2D0*(TT3J-EJ*XW)
34904 XLF=2D0*(TT3I-EI*XW)
34906 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34907 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34908 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34909 C...Factor of 2 for t1 t2bar + t2 t1bar
34910 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34911 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34916 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34917 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34922 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34923 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34926 ELSEIF(ISUB.EQ.264) THEN
34927 C...g + g -> ~t_1 + ~t_1bar
34930 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34931 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34932 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34933 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34934 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34948 ELSEIF(ISUB.LE.280) THEN
34949 IF(ISUB.EQ.271) THEN
34950 C...q + q' -> ~q + ~q' (~g exchange)
34951 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34960 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34961 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34964 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34965 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34966 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34969 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34970 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34971 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34972 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34974 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34977 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34978 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
34980 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
34981 IF(I*J.LT.0) GOTO 420
34986 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34987 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34990 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
34991 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34993 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
34994 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34995 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35002 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35003 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35005 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35006 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35007 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35013 ELSEIF(ISUB.EQ.274) THEN
35014 C...q + qbar' -> ~q + ~qbar'
35015 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35019 C...Mrenna...Normalization.and.1/XMT
35020 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35021 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35022 FACQQB=COMFAC*AS**2*4D0/9D0*(
35023 & (UH*TH-SQM3*SQM4)/SH2 )
35024 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35025 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35026 FACQQB=FACQQB+FACQQ1+FACQQI
35028 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35031 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35032 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35033 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35034 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35036 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35039 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35040 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35042 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35043 IF(I*J.GT.0) GOTO 440
35048 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35049 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35050 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35051 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35055 ELSEIF(ISUB.EQ.277) THEN
35056 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35057 C...if i .eq. j covered in 274
35058 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35059 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35061 DO 460 I=MMIN1,MMAX1
35063 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35064 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35065 IF(IA.EQ.KFNSQ) GOTO 460
35066 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35068 EJ=KCHG(KFNSQ,1)/3D0
35070 T3I=SIGN(1D0,EI)/2D0
35072 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35073 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35075 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35076 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35078 XLF=2D0*(T3I-EI*XW)
35085 TAA=0.5D0*(EI*EJ)**2
35086 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35087 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35088 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35089 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35090 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35091 ELSEIF(IA.LE.6) THEN
35092 FAC0=AS**2*8D0/9D0/2D0
35098 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35101 ELSEIF(ISUB.EQ.279) THEN
35102 C...g + g -> ~q_j + ~q_jbar
35105 C...5=RKF because ~t ~tbar treated separately
35106 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
35107 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35108 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35109 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
35114 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35119 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35129 C*********************************************************************
35132 C...Subprocess cross sections for Technicolor processes.
35133 C...Auxiliary to PYSIGH.
35135 SUBROUTINE PYSGTC(NCHN,SIGS)
35137 C...Double precision and integer declarations
35138 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35139 IMPLICIT INTEGER(I-N)
35140 INTEGER PYK,PYCHGE,PYCOMP
35141 C...Parameter statement to help give large particle numbers.
35142 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35143 &KEXCIT=4000000,KDIMEN=5000000)
35145 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35146 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35147 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35149 COMMON/PYINT1/MINT(400),VINT(400)
35150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35151 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35152 COMMON/PYINT4/MWID(500),WIDS(500,5)
35153 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35154 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35155 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35156 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35157 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35158 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35159 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35160 C...Local arrays and complex variables
35161 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35162 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35163 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35164 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35165 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35166 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35167 COMPLEX*16 DVVS,DVVT,DVVU
35170 C...Combinations of weak mixing angle.
35172 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35174 C...Convert almost equivalent technicolor processes into
35175 C...a few basic processes, and set distinguishing parameters.
35176 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
35179 SN2W=2D0*SQRT(XW*XW1)
35182 CSXI=COS(ASIN(RTCM(3)))
35183 CSXIP=COS(ASIN(RTCM(4)))
35184 QUPD=2D0*RTCM(2)-1D0
35185 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
35196 C... rho_tc0, etc. -> W_L W_L, W_L W_T
35197 IF(ISUB.EQ.361) THEN
35201 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35202 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35203 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
35204 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
35205 AXGP = SQRT(2D0)*AXGP
35206 ARGP = SQRT(2D0)*ARGP
35207 VOGP = SQRT(2D0)*VOGP
35208 C... rho_tc0 -> W_L pi_tc-
35209 ELSEIF(ISUB.EQ.362) THEN
35213 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35215 ELSEIF(ISUB.EQ.363) THEN
35219 CAB2=(1D0-RTCM(3)**2)**2
35220 C... rho_tc0/omega_tc -> gamma pi_tc
35221 ELSEIF(ISUB.EQ.364) THEN
35228 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35230 ELSEIF(ISUB.EQ.365) THEN
35234 VRGP=CSXIP/RTCM(12)
35236 VAGP=2D0*Q2UD*CSXIP
35237 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
35239 ELSEIF(ISUB.EQ.366) THEN
35243 VOGP=CSXI*CT2W/RTCM(12)
35244 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35245 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35246 VZGP=-QUPD*CSXI*CS2W/XW1
35248 ELSEIF(ISUB.EQ.367) THEN
35252 C...RTCM(48) is the M_V for the techni-a
35253 VXGP=-CSXIP/SN2W/RTCM(48)
35254 VRGP=CSXIP*CT2W/RTCM(12)
35255 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
35256 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
35257 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
35259 ELSEIF(ISUB.EQ.368) THEN
35263 C...RTCM(49) is the M_A for the techni-a
35264 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
35265 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
35266 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
35267 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
35268 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35269 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
35270 ELSEIF(ISUB.EQ.370) THEN
35274 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35275 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35277 ELSEIF(ISUB.EQ.371) THEN
35281 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35283 ELSEIF(ISUB.EQ.372) THEN
35287 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35289 ELSEIF(ISUB.EQ.373) THEN
35293 CAB2=(1D0-RTCM(3)**2)**2
35295 ELSEIF(ISUB.EQ.374) THEN
35299 VRGP=QUPD*CSXI/RTCM(12)
35300 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
35301 AXGP=-CSXI/RTCM(49)
35303 ELSEIF(ISUB.EQ.375) THEN
35307 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35308 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
35309 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35310 AXGP=-CSXI*CT2W/RTCM(49)
35312 ELSEIF(ISUB.EQ.376) THEN
35317 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
35318 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
35320 ELSEIF(ISUB.EQ.377) THEN
35324 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
35325 VWGP=CSXIP/(2D0*XW)
35326 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
35328 ELSEIF(ISUB.EQ.378) THEN
35332 VRGP=QUPD*RTCM(3)/RTCM(12)
35333 AXGP=-RTCM(3)/RTCM(49)
35335 ELSEIF(ISUB.EQ.379) THEN
35339 VOGP=RTCM(3)/RTCM(12)
35340 VRGP=QUPD*RTCM(3)/RTCM(12)
35341 ELSEIF(ISUB.EQ.380) THEN
35345 VOGP=RTCM(3)*CT2W/RTCM(12)
35346 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
35350 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
35351 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
35352 IF(ITCM(5).LE.4) THEN
35370 ELSEIF(ITCM(5).EQ.5) THEN
35372 IF(ITCM(2).EQ.0) THEN
35377 ALPRHT=2.16D0*(3D0/ITCM(1))
35378 SIN2T=2D0*TANT3/(TANT3**2+1D0)
35379 SINT3=TANT3/SQRT(TANT3**2+1D0)
35380 XIG=SQRT(PYALPS(SH)/ALPRHT)
35381 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
35382 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
35383 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
35384 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
35385 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
35386 & SINT3**2)*2D0/SIN2T
35387 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
35388 & SINT3**2)*2D0/SIN2T
35390 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
35391 SM1112=X12*RTCM(28)**2*SIN2T
35392 SM1121=-X21*RTCM(28)**2*SIN2T
35395 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
35396 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
35399 ZTC(1,1)=DCMPLX(SH,0D0)
35400 CALL PYWIDT(3100021,SH,WDTP,WDTE)
35401 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
35402 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
35403 CALL PYWIDT(3100113,SH,WDTP,WDTE)
35404 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
35405 CALL PYWIDT(3400113,SH,WDTP,WDTE)
35406 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
35407 CALL PYWIDT(3200113,SH,WDTP,WDTE)
35408 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
35409 CALL PYWIDT(3300113,SH,WDTP,WDTE)
35410 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
35412 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
35416 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
35417 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
35418 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
35419 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
35432 CALL PYLDCM(ZTC,6,6,INDX,D)
35436 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35441 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35447 XIG=SQRT(PYALPS(-TH)/ALPRHT)
35449 ZTC(1,1)=DCMPLX(TH)
35450 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
35451 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
35452 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
35453 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
35454 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
35456 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
35460 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
35461 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
35462 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
35463 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
35475 CALL PYLDCM(ZTC,6,6,INDX,D)
35479 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35483 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35489 XIG=SQRT(PYALPS(-UH)/ALPRHT)
35491 ZTC(1,1)=DCMPLX(UH,0D0)
35492 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
35493 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
35494 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
35495 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
35496 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
35498 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
35502 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
35503 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
35504 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
35505 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
35517 CALL PYLDCM(ZTC,6,6,INDX,D)
35521 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35525 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35532 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
35533 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
35534 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
35535 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
35536 DQGS=DGGS-DGVS*DCMPLX(TANT3)
35537 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35539 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35540 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
35541 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
35542 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35543 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35544 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35547 SQDQTS=ABS(DQTS)**2
35548 SQDQQS=ABS(DQQS)**2
35549 SQDQQT=ABS(DQQT)**2
35550 SQDQQU=ABS(DQQU)**2
35551 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
35553 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
35555 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
35557 SQDGGS=ABS(DGGS)**2
35558 SQDGGT=ABS(DGGT)**2
35559 SQDGGU=ABS(DGGU)**2
35563 REDGTU=DBLE(DGGU*DCONJG(DGGT))
35564 REDGSU=DBLE(DGGU*DCONJG(DGGS))
35565 REDGST=DBLE(DGGS*DCONJG(DGGT))
35566 REDQST=DBLE(DQQS*DCONJG(DQQT))
35567 REDQTU=DBLE(DQQT*DCONJG(DQQU))
35572 C...Differential cross section expressions.
35574 IF(ISUB.LE.190) THEN
35575 IF(ISUB.EQ.149) THEN
35576 C...g + g -> eta_tc
35577 KCTC=PYCOMP(KTECHN+331)
35578 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
35580 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
35581 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35583 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
35585 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35590 SIGH(NCHN)=HI*FACBW*HF
35593 ELSEIF(ISUB.EQ.165) THEN
35594 C...q + qbar -> l+ + l- (including contact term for compositeness)
35595 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35596 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35597 KFF=IABS(KFPR(ISUB,1))
35599 AF=SIGN(1D0,EF+0.1D0)
35604 IF(KFF.LE.10) FCOF=3D0
35606 IF(KFF.EQ.6) WID2=WIDS(6,1)
35607 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
35608 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35609 DO 260 I=MMINA,MMAXA
35610 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
35611 EI=KCHG(IABS(I),1)/3D0
35612 AI=SIGN(1D0,EI+0.1D0)
35617 IF(IABS(I).LE.10) FCOI=FACA/3D0
35618 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
35619 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
35620 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
35621 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35623 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
35624 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35626 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
35627 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
35628 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
35629 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
35630 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
35635 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
35638 ELSEIF(ISUB.EQ.166) THEN
35639 C...q + q'bar -> l + nu_l (including contact term for compositeness)
35640 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
35641 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
35642 KFF=IABS(KFPR(ISUB,1))
35644 IF(KFF.LE.10) FCOF=3D0
35645 DO 280 I=MMIN1,MMAX1
35646 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
35648 DO 270 J=MMIN2,MMAX2
35649 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
35651 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
35652 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35655 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35657 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
35658 & MOD(J,2).EQ.0)) THEN
35659 IF(KFF.EQ.5) WID2=WIDS(6,2)
35660 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
35661 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
35663 IF(KFF.EQ.5) WID2=WIDS(6,3)
35664 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
35665 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
35671 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
35672 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
35673 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
35678 ELSEIF(ISUB.LE.200) THEN
35679 IF(ISUB.EQ.191) THEN
35680 C...q + qbar -> rho_tc0.
35681 KCTC=PYCOMP(KTECHN+113)
35682 SQMRHT=PMAS(KCTC,1)**2
35683 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35685 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35686 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35687 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35688 ALPRHT=2.16D0*(3D0/ITCM(1))
35689 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
35690 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
35691 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35692 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35693 DO 290 I=MMINA,MMAXA
35694 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
35696 EI=KCHG(IABS(I),1)/3D0
35697 AI=SIGN(1D0,EI+0.1D0)
35701 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
35702 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
35703 IF(IA.LE.10) HI=HI*FACA/3D0
35708 SIGH(NCHN)=HI*FACBW*HF
35711 ELSEIF(ISUB.EQ.192) THEN
35712 C...q + qbar' -> rho_tc+/-.
35713 KCTC=PYCOMP(KTECHN+213)
35714 SQMRHT=PMAS(KCTC,1)**2
35715 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35717 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35718 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35719 ALPRHT=2.16D0*(3D0/ITCM(1))
35720 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
35721 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
35722 DO 310 I=MMIN1,MMAX1
35723 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
35725 DO 300 J=MMIN2,MMAX2
35726 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
35728 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
35729 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35731 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35732 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
35734 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35739 SIGH(NCHN)=HI*FACBW*HF
35743 ELSEIF(ISUB.EQ.193) THEN
35744 C...q + qbar -> omega_tc0.
35745 KCTC=PYCOMP(KTECHN+223)
35746 SQMOMT=PMAS(KCTC,1)**2
35747 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35749 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
35750 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35751 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35752 ALPRHT=2.16D0*(3D0/ITCM(1))
35753 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
35754 & (2D0*RTCM(2)-1D0)**2
35755 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35756 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35757 DO 320 I=MMINA,MMAXA
35758 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
35760 EI=KCHG(IABS(I),1)/3D0
35761 AI=SIGN(1D0,EI+0.1D0)
35765 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
35766 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
35767 IF(IA.LE.10) HI=HI*FACA/3D0
35772 SIGH(NCHN)=HI*FACBW*HF
35775 ELSEIF(ISUB.EQ.194) THEN
35776 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
35777 C...Default final state is e+e-
35779 ALPRHT=2.16D0*(3D0/ITCM(1))
35782 SN2W=2D0*SQRT(XW*XW1)
35783 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
35784 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
35786 QUPD=2D0*RTCM(2)-1D0
35787 FAR=SQRT(AEM/ALPRHT)
35791 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35792 FZX=-FAR/SN2W*RTCM(47)
35798 CALL PYWIDT(23,SH,WDTP,WDTE)
35799 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35800 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35801 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35802 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35803 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35804 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35805 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35806 C...Propagator including a_T^0
35807 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35808 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35809 C...Add in techni-a contribution
35810 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35811 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35812 $ SFZX*SSMR*SSMO)/DETD/SH
35813 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35814 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35816 XWRHT=1D0/(4D0*XW*(1D0-XW))
35817 KFF=IABS(KFPR(ISUB,1))
35819 AF=SIGN(1D0,EF+0.1D0)
35824 IF(KFF.LE.10) FCOF=3D0
35827 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
35828 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35829 DZZ=DZZ*DCMPLX(XWRHT,0D0)
35830 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
35832 DO 330 I=MMINA,MMAXA
35833 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
35834 EI=KCHG(IABS(I),1)/3D0
35835 AI=SIGN(1D0,EI+0.1D0)
35840 IF(IABS(I).LE.10) FCOI=FCOI/3D0
35841 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
35842 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
35843 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
35844 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
35845 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
35846 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
35851 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
35854 ELSEIF(ISUB.EQ.195) THEN
35855 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
35858 ALPRHT=2.16D0*(3D0/ITCM(1))
35859 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
35861 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35862 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35864 C...Propagator including a_T^+
35866 CALL PYWIDT(24,SH,WDTP,WDTE)
35867 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35868 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35869 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35870 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
35871 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
35872 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
35873 & DCMPLX(FWX**2,0D0)*SSMR
35874 DWW=SSMR*SSMX/DETD/SH
35876 IF(KFA.LE.8) FCOF=3D0
35877 HP=FACTC*ABS(DWW)**2*FCOF
35879 DO 350 I=MMIN1,MMAX1
35880 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
35882 DO 340 J=MMIN2,MMAX2
35883 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
35885 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
35886 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35888 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35890 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35895 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
35900 ELSEIF(ISUB.LE.380) THEN
35901 ALPRHT=2.16D0*(3D0/ITCM(1))
35902 IF(ISUB.EQ.361) THEN
35903 FAR=SQRT(AEM/ALPRHT)
35907 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35908 FZX=-FAR/SN2W*RTCM(47)
35914 CALL PYWIDT(23,SH,WDTP,WDTE)
35915 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35916 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35917 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35918 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35919 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35920 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35921 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35922 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35923 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35924 C...Add in techni-a contribution
35925 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35926 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
35927 $ SFZX*FAR*SSMO)/DETD/SH
35928 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
35929 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
35930 $ SFZX*FAO*SSMR)/DETD/SH
35931 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
35932 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
35933 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
35934 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35935 $ SFZX*SSMR*SSMO)/DETD/SH
35936 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35937 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35939 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35940 C...W+W-, W pi_tc, pi_T pi_T, etc.
35941 FACA=(SH**2*BE34**2-(TH-UH)**2)
35942 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35943 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35944 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35945 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35946 DO 370 I=MMINA,MMAXA
35947 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35949 EI=KCHG(IABS(I),1)/3D0
35950 AI=SIGN(1D0,EI+0.1D0)
35952 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
35953 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
35954 C...........Eqs. (5) and (6) in LSTC-rates.pdf
35955 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35956 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35957 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
35958 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35959 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35960 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35961 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35962 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
35963 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35964 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35965 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35966 C...........Eqs. (5) and (7) in LSTC-rates.pdf
35967 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35968 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35969 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
35970 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35971 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35972 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
35973 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35975 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
35977 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35978 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35979 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35980 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35981 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35982 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35983 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
35985 IF(IA.LE.10) HI=HI/3D0
35990 IF(KFA.EQ.KFB) THEN
35991 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
35992 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
35993 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35998 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36000 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36004 ELSEIF(ISUB.EQ.370) THEN
36005 C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
36006 C...f + fbar' -> gamma pi_tc, etc.
36007 FACA=(SH**2*BE34**2-(TH-UH)**2)
36008 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36009 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36010 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36011 ALPRHT=2.16D0*(3D0/ITCM(1))
36012 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36013 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36014 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36016 CALL PYWIDT(24,SH,WDTP,WDTE)
36017 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36018 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36019 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36020 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36021 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36022 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36023 & DCMPLX(FWX**2,0D0)*SSMR
36024 DWW=SSMR*SSMX/DETD/SH
36025 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36026 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36027 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36028 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36030 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36032 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36033 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36034 C...Add in W_L Z_T axial and vector contributions.
36035 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36036 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36037 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36038 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36039 DO 410 I=MMIN1,MMAX1
36040 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36042 DO 400 J=MMIN2,MMAX2
36043 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36045 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36046 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36048 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36050 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36055 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36056 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36058 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36059 & WIDS(PYCOMP(KFB),2)
36065 ELSEIF(ISUB.LE.390) THEN
36066 IF(ISUB.EQ.381) THEN
36067 C...f + f' -> f + f' (g exchange)
36068 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36069 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36070 & MSTP(34)*2D0/3D0*UH2*REDQST)
36071 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36072 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36073 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36074 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36075 C...Modifications from contact interactions (compositeness)
36076 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36077 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36078 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36079 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36080 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36081 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36082 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36083 ELSEIF(ITCM(5).EQ.5) THEN
36088 CSM.......Check this change from
36092 DO 430 I=MMIN1,MMAX1
36094 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36095 DO 420 J=MMIN2,MMAX2
36097 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36102 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36105 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
36108 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
36109 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
36116 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
36117 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
36118 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
36120 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
36121 SIGH(NCHN)=0.5D0*FACCI2*RATCII
36127 ELSEIF(ISUB.EQ.382) THEN
36128 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36129 CALL PYWIDT(21,SH,WDTP,WDTE)
36130 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
36131 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36132 IF(ITCM(5).EQ.1) THEN
36133 C...Modifications from contact interactions (compositeness)
36136 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
36137 & WDTE(I,2)+WDTE(I,4))
36139 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
36140 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
36141 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36142 ELSEIF(ITCM(5).EQ.5) THEN
36143 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
36144 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
36145 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
36147 DO 450 I=MMINA,MMAXA
36148 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36149 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
36154 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
36156 ELSEIF(ITCM(5).EQ.5) THEN
36168 ELSEIF(ISUB.EQ.383) THEN
36169 C...f + fbar -> g + g (q + qbar -> g + g only)
36170 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36171 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36172 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36173 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36174 IF(ITCM(5).EQ.5) THEN
36175 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36176 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36177 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36178 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36180 DO 460 I=MMINA,MMAXA
36181 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36182 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36187 SIGH(NCHN)=0.5D0*FACGG1
36188 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
36193 SIGH(NCHN)=0.5D0*FACGG2
36194 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
36197 ELSEIF(ISUB.EQ.384) THEN
36198 C...f + g -> f + g (q + g -> q + g only)
36199 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
36200 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
36201 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
36202 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
36203 DO 480 I=MMINA,MMAXA
36204 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
36206 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
36207 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
36210 ISIG(NCHN,3-ISDE)=21
36215 ISIG(NCHN,3-ISDE)=21
36221 ELSEIF(ISUB.EQ.385) THEN
36222 C...g + g -> f + fbar (g + g -> q + qbar only)
36223 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
36225 C...Begin by d, u, s flavours.
36227 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
36228 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
36229 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
36230 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
36231 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
36232 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
36233 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36234 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36235 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36236 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36247 C...Next c and b flavours: modified that and uhat for fixed
36248 C...cos(theta-hat).
36250 SQMAVG=PMAS(IFL,1)**2
36251 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
36252 BE34=SQRT(1D0-4D0*SQMAVG/SH)
36253 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36254 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36255 THUHQ=THQ*UHQ-SQMAVG*SH
36256 IF(MSTP(34).EQ.0) THEN
36257 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36258 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36260 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36261 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36262 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36263 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36265 IF(ITCM(5).GE.5) THEN
36267 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36268 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36269 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36270 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36272 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36273 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36274 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36275 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36278 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
36279 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
36283 ISIG(NCHN,3)=1+2*(IFL-3)
36288 ISIG(NCHN,3)=2+2*(IFL-3)
36294 ELSEIF(ISUB.EQ.386) THEN
36296 IF(ITCM(5).LE.4) THEN
36297 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
36298 & 2D0*TH/SH+TH2/SH2)*FACA
36299 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
36300 & 2D0*SH/UH+SH2/UH2)*FACA
36301 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
36302 & 2D0*UH/TH+UH2/TH2)
36304 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
36305 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
36306 & 4D0*REDGST*(SH + 2D0*TH)*
36307 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
36308 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
36309 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
36310 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
36311 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
36312 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
36313 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
36314 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
36315 & 4D0*REDGSU*(SH + 2D0*UH)*
36316 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
36317 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
36318 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
36319 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
36320 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
36321 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
36322 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
36323 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
36324 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
36325 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
36326 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
36327 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
36328 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
36329 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
36330 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
36331 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
36332 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
36333 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
36334 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
36335 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
36336 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
36337 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
36339 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
36344 SIGH(NCHN)=0.5D0*FACGG1
36349 SIGH(NCHN)=0.5D0*FACGG2
36354 SIGH(NCHN)=0.5D0*FACGG3
36357 ELSEIF(ISUB.EQ.387) THEN
36358 C...q + qbar -> Q + Qbar
36359 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36360 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36361 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36362 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
36364 IF(ITCM(5).GE.5) THEN
36365 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36366 FACQQB=FACQQB*SH2*SQDQTS
36368 FACQQB=FACQQB*SH2*SQDQQS
36371 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
36373 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36374 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36376 DO 520 I=MMINA,MMAXA
36377 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36378 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
36386 ELSEIF(ISUB.EQ.388) THEN
36387 C...g + g -> Q + Qbar
36388 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36389 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36390 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36391 THUHQ=THQ*UHQ-SQMAVG*SH
36392 IF(MSTP(34).EQ.0) THEN
36393 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36394 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36396 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36397 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36398 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36399 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36401 IF(ITCM(5).GE.5) THEN
36402 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36403 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36404 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36405 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36406 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36408 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36409 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36410 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36411 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36414 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
36415 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
36416 IF(MSTP(35).GE.1) THEN
36417 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
36418 FACQQ1=FACQQ1*FATRE
36419 FACQQ2=FACQQ2*FATRE
36422 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36423 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36426 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
36446 C*********************************************************************
36449 C...Subprocess cross sections for assorted exotic processes,
36450 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
36451 C...Auxiliary to PYSIGH.
36453 SUBROUTINE PYSGEX(NCHN,SIGS)
36455 C...Double precision and integer declarations
36456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36457 IMPLICIT INTEGER(I-N)
36458 INTEGER PYK,PYCHGE,PYCOMP
36459 C...Parameter statement to help give large particle numbers.
36460 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36461 &KEXCIT=4000000,KDIMEN=5000000)
36463 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36465 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36466 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36467 COMMON/PYINT1/MINT(400),VINT(400)
36468 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36469 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36470 COMMON/PYINT4/MWID(500),WIDS(500,5)
36471 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36472 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36473 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36474 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36475 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36476 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36477 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36479 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36481 C...Differential cross section expressions.
36483 IF(ISUB.LE.160) THEN
36484 IF(ISUB.EQ.141) THEN
36485 C...f + fbar -> gamma*/Z0/Z'0
36486 SQMZP=PMAS(32,1)**2
36488 CALL PYWIDT(32,SH,WDTP,WDTE)
36494 FACZP=4D0*COMFAC*3D0
36495 DO 100 I=MMINA,MMAXA
36496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
36497 EI=KCHG(IABS(I),1)/3D0
36503 VPI=PARU(123-2*MOD(IABS(I),2))
36504 API=PARU(124-2*MOD(IABS(I),2))
36505 ELSEIF(IA.LE.4) THEN
36506 VPI=PARJ(182-2*MOD(IABS(I),2))
36507 API=PARJ(183-2*MOD(IABS(I),2))
36509 VPI=PARJ(190-2*MOD(IABS(I),2))
36510 API=PARJ(191-2*MOD(IABS(I),2))
36514 VPI=PARU(127-2*MOD(IABS(I),2))
36515 API=PARU(128-2*MOD(IABS(I),2))
36516 ELSEIF(IA.LE.14) THEN
36517 VPI=PARJ(186-2*MOD(IABS(I),2))
36518 API=PARJ(187-2*MOD(IABS(I),2))
36520 VPI=PARJ(194-2*MOD(IABS(I),2))
36521 API=PARJ(195-2*MOD(IABS(I),2))
36525 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
36527 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
36529 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
36534 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
36535 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
36536 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
36537 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
36538 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
36539 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
36540 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
36541 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
36544 ELSEIF(ISUB.EQ.142) THEN
36545 C...f + fbar' -> W'+/-
36546 SQMWP=PMAS(34,1)**2
36547 CALL PYWIDT(34,SH,WDTP,WDTE)
36549 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
36550 HP=AEM/(24D0*XW)*SH
36551 DO 120 I=MMIN1,MMAX1
36552 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
36554 DO 110 J=MMIN2,MMAX2
36555 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
36557 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
36558 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36560 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36561 HI=HP*(PARU(133)**2+PARU(134)**2)
36562 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
36563 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36568 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36569 SIGH(NCHN)=HI*FACBW*HF
36573 ELSEIF(ISUB.EQ.144) THEN
36576 CALL PYWIDT(41,SH,WDTP,WDTE)
36578 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
36579 HP=AEM/(12D0*XW)*SH
36580 DO 140 I=MMIN1,MMAX1
36581 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
36583 DO 130 J=MMIN2,MMAX2
36584 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
36586 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
36588 IF(IA.LE.10) HI=HI*FACA/3D0
36589 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
36594 SIGH(NCHN)=HI*FACBW*HF
36598 ELSEIF(ISUB.EQ.145) THEN
36599 C...q + l -> LQ (leptoquark)
36600 SQMLQ=PMAS(42,1)**2
36601 CALL PYWIDT(42,SH,WDTP,WDTE)
36603 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
36604 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
36606 KFLQQ=KFDP(MDCY(42,2),1)
36607 KFLQL=KFDP(MDCY(42,2),2)
36608 DO 160 I=MMIN1,MMAX1
36609 IF(KFAC(1,I).EQ.0) GOTO 160
36611 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
36612 DO 150 J=MMIN2,MMAX2
36613 IF(KFAC(2,J).EQ.0) GOTO 150
36615 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
36616 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
36617 IF(JA.EQ.IA) GOTO 150
36618 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
36619 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
36621 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
36626 SIGH(NCHN)=HI*FACBW*HF
36630 ELSEIF(ISUB.EQ.146) THEN
36631 C...e + gamma* -> e* (excited lepton)
36632 KFQSTR=KFPR(ISUB,1)
36633 KCQSTR=PYCOMP(KFQSTR)
36634 KFQEXC=MOD(KFQSTR,KEXCIT)
36635 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36637 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36638 QF=-RTCM(43)/2D0-RTCM(44)/2D0
36639 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
36640 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36643 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
36645 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
36646 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
36648 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36649 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36652 ISIG(NCHN,3-ISDE)=22
36654 SIGH(NCHN)=HI*FACBW*HF
36658 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
36659 C...d + g -> d* and u + g -> u* (excited quarks)
36660 KFQSTR=KFPR(ISUB,1)
36661 KCQSTR=PYCOMP(KFQSTR)
36662 KFQEXC=MOD(KFQSTR,KEXCIT)
36663 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36665 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36666 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
36667 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36670 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
36672 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
36673 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
36675 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36676 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36679 ISIG(NCHN,3-ISDE)=21
36681 SIGH(NCHN)=HI*FACBW*HF
36686 ELSEIF(ISUB.LE.190) THEN
36687 IF(ISUB.EQ.162) THEN
36688 C...q + g -> LQ + lbar; LQ=leptoquark
36689 SQMLQ=PMAS(42,1)**2
36690 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
36691 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
36692 KFLQQ=KFDP(MDCY(42,2),1)
36693 DO 220 I=MMINA,MMAXA
36694 IF(IABS(I).NE.KFLQQ) GOTO 220
36697 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
36698 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
36701 ISIG(NCHN,3-ISDE)=21
36703 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
36707 ELSEIF(ISUB.EQ.163) THEN
36708 C...g + g -> LQ + LQbar; LQ=leptoquark
36709 SQMLQ=PMAS(42,1)**2
36710 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
36711 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
36712 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
36713 & ((TH-SQMLQ)*(UH-SQMLQ)))
36714 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
36718 C...Since don't know proper colour flow, randomize between alternatives
36719 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
36723 ELSEIF(ISUB.EQ.164) THEN
36724 C...q + qbar -> LQ + LQbar; LQ=leptoquark
36725 DELTA=0.25D0*(SQM3-SQM4)**2/SH
36726 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
36729 C SQMLQ=PMAS(42,1)**2
36730 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
36731 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
36732 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
36733 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
36734 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
36735 KFLQQ=KFDP(MDCY(42,2),1)
36736 DO 240 I=MMINA,MMAXA
36737 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36738 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
36744 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
36747 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
36748 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
36749 KFQSTR=KFPR(ISUB,2)
36750 KCQSTR=PYCOMP(KFQSTR)
36751 KFQEXC=MOD(KFQSTR,KEXCIT)
36752 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
36753 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36754 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36755 C...Propagators: as simulated in PYOFSH and as desired
36756 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36757 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36758 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36759 GMMQC=SQRT(SQM4)*WDTP(0)
36760 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36761 FACQSA=FACQSA*HBW4C/HBW4
36762 FACQSB=FACQSB*HBW4C/HBW4
36763 C...Branching ratios.
36764 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36765 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36766 DO 260 I=MMIN1,MMAX1
36768 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
36769 DO 250 J=MMIN2,MMAX2
36771 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
36772 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
36777 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36778 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36783 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36784 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36785 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
36790 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36791 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
36792 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
36793 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
36798 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36799 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36804 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36805 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36806 ELSEIF(I.EQ.-J) THEN
36811 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36812 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36817 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36818 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36819 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
36824 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36825 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
36826 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
36831 ELSEIF(ISUB.EQ.169) THEN
36832 C...q + qbar -> e + e* (excited lepton)
36833 KFQSTR=KFPR(ISUB,2)
36834 KCQSTR=PYCOMP(KFQSTR)
36835 KFQEXC=MOD(KFQSTR,KEXCIT)
36836 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36837 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36838 C...Propagators: as simulated in PYOFSH and as desired
36839 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36840 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36841 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36842 GMMQC=SQRT(SQM4)*WDTP(0)
36843 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36844 FACQSB=FACQSB*HBW4C/HBW4
36845 C...Branching ratios.
36846 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36847 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36848 DO 270 I=MMIN1,MMAX1
36850 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
36853 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
36858 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36859 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36864 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36865 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36869 ELSEIF(ISUB.LE.360) THEN
36870 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
36871 C...l + l -> H_L++/-- or H_R++/--.
36873 KFREC=PYCOMP(KFRES)
36874 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36876 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
36877 DO 290 I=MMIN1,MMAX1
36879 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
36881 DO 280 J=MMIN2,MMAX2
36883 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
36885 IF(I*J.LT.0) GOTO 280
36886 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36891 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
36892 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36893 SIGH(NCHN)=HI*FACBW*HF
36897 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
36898 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
36900 KFREC=PYCOMP(KFRES)
36901 C...Propagators: as simulated in PYOFSH and as desired
36902 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
36903 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
36904 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36905 GMMC=SQRT(SQM3)*WDTP(0)
36906 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
36907 FHCC=COMFAC*AEM*HBW3C/HBW3
36908 DO 310 I=MMINA,MMAXA
36910 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36912 J=ISIGN(KFPR(ISUB,2),-I)
36913 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36914 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36915 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36917 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36918 & (TH-SQM4)*SH)/(TH-SQM4)**2
36919 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36921 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36922 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36923 & ((UH-SQM3)*(TH-SQM4))
36924 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36925 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36926 & ((UH-SQM3)*(SH-SQML))
36927 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36928 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36929 & ((SH-SQML)*(TH-SQM4))
36930 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36931 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36933 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36934 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36937 ISIG(NCHN,3-ISDE)=22
36939 SIGH(NCHN)=FHCC*SMM*WIDSC
36943 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36944 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36946 KFREC=PYCOMP(KFRES)
36947 SQMH=PMAS(KFREC,1)**2
36948 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36949 C...Propagators: H++/-- as simulated in PYOFSH and as desired
36950 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36951 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36952 GMMH3=SQRT(SQM3)*WDTP(0)
36953 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36954 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36955 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36956 GMMH4=SQRT(SQM4)*WDTP(0)
36957 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36958 C...Kinematical and coupling functions
36959 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36960 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36961 C...Loop over allowed flavours
36962 DO 320 I=MMINA,MMAXA
36963 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36964 EI=KCHG(IABS(I),1)/3D0
36965 AI=SIGN(1D0,EI+0.1D0)
36968 IF(IABS(I).LE.10) FCOI=FACA/3D0
36969 IF(ISUB.EQ.349) THEN
36970 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36971 IF(IABS(I).LT.10) THEN
36972 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36973 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36974 & (VI**2+AI**2)*XWHH**2*HBWZ)
36976 IAOFF=181+3*((IABS(I)-11)/2)
36977 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36979 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36980 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36981 & (VI**2+AI**2)*XWHH**2*HBWZ)+
36982 & 8D0*AEM*(EI*HSUM/(SH*TH)+
36983 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
36987 IF(IABS(I).LT.10) THEN
36988 DSIGHH=8D0*AEM**2*EI**2/SH2
36990 IAOFF=181+3*((IABS(I)-11)/2)
36991 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36993 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37001 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37004 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37005 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37007 KFREC=PYCOMP(KFRES)
37008 SQMH=PMAS(KFREC,1)**2
37009 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37010 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37011 & PMAS(PYCOMP(9900024),1)**2
37012 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37013 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37014 & (VINT(209)**2-VINT(216)))
37015 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37016 & (VINT(209)**2+2D0*VINT(218)))
37017 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37019 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37020 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37022 DO 340 I=MMIN1,MMAX1
37023 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37024 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37025 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37026 DO 330 J=MMIN2,MMAX2
37027 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37028 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37029 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37031 IF(IABS(KCHH).NE.2) GOTO 330
37032 FACLR=VINT(180+I)*VINT(180+J)
37033 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37034 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37035 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37043 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37047 ELSEIF(ISUB.EQ.353) THEN
37048 C...f + fbar -> Z_R0
37049 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37050 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37052 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37054 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37055 DO 350 I=MMINA,MMAXA
37056 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37057 IF(IABS(I).LE.8) THEN
37058 EI=KCHG(IABS(I),1)/3D0
37059 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37060 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37065 HI=HP*(VI**2+AI**2)
37066 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37071 SIGH(NCHN)=HI*FACBW*HF
37074 ELSEIF(ISUB.EQ.354) THEN
37075 C...f + fbar' -> W_R+/-
37076 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37077 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37079 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
37080 HP=AEM/(24D0*XW)*SH
37081 DO 370 I=MMIN1,MMAX1
37082 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
37084 DO 360 J=MMIN2,MMAX2
37085 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
37087 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
37088 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37090 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37092 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37097 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37098 SIGH(NCHN)=HI*FACBW*HF
37103 ELSEIF(ISUB.LE.400) THEN
37104 IF(ISUB.EQ.391) THEN
37105 C...f + fbar -> G*.
37106 KFGSTR=KFPR(ISUB,1)
37107 KCGSTR=PYCOMP(KFGSTR)
37108 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37110 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37111 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
37112 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37113 C...Modify cross section in wings of peak.
37114 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37115 DO 380 I=MMINA,MMAXA
37116 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
37118 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37126 ELSEIF(ISUB.EQ.392) THEN
37128 KFGSTR=KFPR(ISUB,1)
37129 KCGSTR=PYCOMP(KFGSTR)
37130 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37132 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37133 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
37134 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37135 C...Modify cross section in wings of peak.
37136 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37137 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
37145 ELSEIF(ISUB.EQ.393) THEN
37146 C...q + qbar -> g + G*.
37147 KFGSTR=KFPR(ISUB,2)
37148 KCGSTR=PYCOMP(KFGSTR)
37149 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
37150 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
37151 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
37153 C...Propagators: as simulated in PYOFSH and as desired
37154 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37155 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37156 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37157 HS=SQRT(SQM4)*WDTP(0)
37158 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37159 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37160 FACG=FACG*HBW4C/HBW4
37161 DO 400 I=MMINA,MMAXA
37162 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37163 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
37171 ELSEIF(ISUB.EQ.394) THEN
37172 C...q + g -> q + G*.
37173 KFGSTR=KFPR(ISUB,2)
37174 KCGSTR=PYCOMP(KFGSTR)
37175 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
37176 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
37177 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
37178 & 2D0*TH2*TH/(UH*SH2))
37179 C...Propagators: as simulated in PYOFSH and as desired
37180 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37181 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37182 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37183 HS=SQRT(SQM4)*WDTP(0)
37184 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37185 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37186 FACG=FACG*HBW4C/HBW4
37187 DO 420 I=MMINA,MMAXA
37188 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
37190 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
37191 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
37194 ISIG(NCHN,3-ISDE)=21
37200 ELSEIF(ISUB.EQ.395) THEN
37201 C...g + g -> g + G*.
37202 KFGSTR=KFPR(ISUB,2)
37203 KCGSTR=PYCOMP(KFGSTR)
37204 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
37205 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
37206 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
37207 C...Propagators: as simulated in PYOFSH and as desired
37208 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37209 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37210 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37211 HS=SQRT(SQM4)*WDTP(0)
37212 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37213 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37214 FACG=FACG*HBW4C/HBW4
37215 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
37228 C*********************************************************************
37231 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
37232 C...parton distributions according to a few different parametrizations.
37233 C...Note that what is coded is x times the probability distribution,
37234 C...i.e. xq(x,Q2) etc.
37236 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
37238 C...Double precision and integer declarations.
37239 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37240 IMPLICIT INTEGER(I-N)
37241 INTEGER PYK,PYCHGE,PYCOMP
37243 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37246 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37247 COMMON/PYINT1/MINT(400),VINT(400)
37248 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37250 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37251 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
37252 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
37253 & XMI(2,240),PT2MI(240),IMISEP(0:240)
37254 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
37257 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
37258 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
37261 C...Interface to PDFLIB.
37262 COMMON/LW50513/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...Data related to Schuler-Sjostrand photon distributions.
37270 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
37272 C...Valence PDF momentum integral parametrizations PER PARTON!
37273 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
37274 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
37275 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
37276 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
37278 C...Reset parton distributions.
37287 C...Check x and particle species.
37288 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37289 WRITE(MSTU(11),5000) X
37293 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
37294 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
37295 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
37296 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
37297 &KFA.NE.310.AND.KFA.NE.130) THEN
37298 WRITE(MSTU(11),5100) KF
37302 C...Electron (or muon or tau) parton distribution call.
37303 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
37304 CALL PYPDEL(KFA,X,Q2,XPEL)
37309 C...Photon parton distribution call (VDM+anomalous).
37310 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
37311 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
37312 CALL PYPDGA(X,Q2,XPGA)
37316 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37319 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37320 XPVAL(4)=MIN(XPQ(4),XPVU)
37321 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37327 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37330 IF(MSTP(55).GE.7) P2MX=4.0D0
37331 IF(MSTP(57).EQ.0) Q2MX=P2MX
37333 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37334 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37337 XPVAL(KFL)=VXPDGM(KFL)
37340 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37343 IF(MSTP(55).GE.11) P2MX=4.0D0
37344 IF(MSTP(57).EQ.0) Q2MX=P2MX
37346 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37347 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37349 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37350 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37353 ELSEIF(MSTP(56).EQ.2) THEN
37354 C...Call PDFLIB parton distributions.
37358 VALUE(2)=MSTP(55)/1000
37360 VALUE(3)=MOD(MSTP(55),1000)
37361 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37362 CALL PDFSET(PARM,VALUE)
37363 MINT(93)=3000000+MSTP(55)
37366 QQ2=MAX(0D0,Q2MIN,Q2)
37367 IF(MSTP(57).EQ.0) QQ2=Q2MIN
37369 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37371 IF(MSTP(55).EQ.5004) THEN
37372 IF(5D0*P2.LT.QQ2.AND.
37373 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
37374 & P2.GE.0D0.AND.P2.LT.10D0.AND.
37375 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
37376 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37391 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37419 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37422 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37423 XPVAL(4)=MIN(XPQ(4),XPVU)
37424 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37431 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
37434 C...Pion/gammaVDM parton distribution call.
37435 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
37436 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37437 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
37438 & MSTP(55).LE.12) THEN
37439 ISET=1+MOD(MSTP(55)-1,4)
37442 IF(ISET.GE.3) P2MX=4.0D0
37443 IF(MSTP(57).EQ.0) Q2MX=P2MX
37445 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37446 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37448 XPQ(KFL)=XPVMD(KFL)
37449 XPVAL(KFL)=VXPVMD(KFL)
37452 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
37453 CALL PYPDPI(X,Q2,XPPI)
37457 XPVAL(2)=XPQ(2)-XPQ(-2)
37458 XPVAL(-1)=XPQ(-1)-XPQ(1)
37459 ELSEIF(MSTP(54).EQ.2) THEN
37460 C...Call PDFLIB parton distributions.
37464 VALUE(2)=MSTP(53)/1000
37466 VALUE(3)=MOD(MSTP(53),1000)
37467 IF(MINT(93).NE.2000000+MSTP(53)) THEN
37468 CALL PDFSET(PARM,VALUE)
37469 MINT(93)=2000000+MSTP(53)
37472 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37473 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37474 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37492 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
37495 C...Anomalous photon parton distribution call.
37496 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
37499 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
37500 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
37501 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
37502 IF(MSTP(57).EQ.0) Q2MX=P2MX
37504 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37505 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37507 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
37508 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
37511 ELSEIF(MSTP(56).EQ.1) THEN
37512 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
37513 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
37514 IF(MSTP(57).EQ.0) Q2MX=P2MX
37516 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37517 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37519 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37520 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37523 ELSEIF(MSTP(56).EQ.2) THEN
37524 IF(MSTP(57).EQ.0) Q2MX=P2MX
37525 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
37528 XPVAL(KFL)=VXPGA(KFL)
37531 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
37532 IF(MSTP(57).EQ.0) Q2MX=P2MX
37533 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37536 XPVAL(KFL)=VXPGA(KFL)
37540 220 RKF=11D0*PYR(0)
37542 IF(RKF.GT.1D0) KFR=2
37543 IF(RKF.GT.5D0) KFR=3
37544 IF(RKF.GT.6D0) KFR=4
37545 IF(RKF.GT.10D0) KFR=5
37546 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
37547 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
37548 IF(MSTP(57).EQ.0) Q2MX=P2MX
37549 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37552 XPVAL(KFL)=VXPGA(KFL)
37557 C...Proton parton distribution call.
37559 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
37560 CALL PYPDPR(X,Q2,XPPR)
37564 XPVAL(1)=XPQ(1)-XPQ(-1)
37565 XPVAL(2)=XPQ(2)-XPQ(-2)
37566 ELSEIF(MSTP(52).EQ.2) THEN
37567 C...Call PDFLIB parton distributions.
37571 VALUE(2)=MSTP(51)/1000
37573 VALUE(3)=MOD(MSTP(51),1000)
37574 IF(MINT(93).NE.1000000+MSTP(51)) THEN
37575 CALL PDFSET(PARM,VALUE)
37576 MINT(93)=1000000+MSTP(51)
37579 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37580 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37582 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37600 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
37604 C...Isospin average for pi0/gammaVDM.
37605 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37606 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
37611 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37612 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37616 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
37617 & XPVAL(3)+XPVAL(4)+XPVAL(5)
37621 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
37622 XPQ(1)=XPQ(1)+0.2D0*XPV
37623 XPQ(2)=XPQ(2)+0.8D0*XPV
37624 XPVAL(1)=0.2D0*XPVL
37625 XPVAL(2)=0.8D0*XPVL
37626 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
37629 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
37632 IF(MSTP(55).GE.9) THEN
37638 XPQ(1)=XPQ(1)+0.5D0*XPV
37639 XPQ(2)=XPQ(2)+0.5D0*XPV
37640 XPVAL(1)=0.5D0*XPVL
37641 XPVAL(2)=0.5D0*XPVL
37645 XPVAL(-KFL)=XPVAL(KFL)
37648 C...Rescale for gammaVDM by effective gamma -> rho coupling.
37649 C+++Do not rescale?
37650 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
37651 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
37653 XPQ(KFL)=VINT(281)*XPQ(KFL)
37654 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
37656 VINT(232)=VINT(281)*XPV
37659 C...Simple recipes for kaons.
37660 ELSEIF(KFA.EQ.321) THEN
37661 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
37663 XPVAL(-3)=XPVAL(-1)
37665 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
37666 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37667 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37670 XPQ(1)=XPQ(1)+0.5D0*XPV
37671 XPQ(-1)=XPQ(-1)+0.5D0*XPV
37672 XPQ(3)=XPQ(3)+0.5D0*XPV
37673 XPQ(-3)=XPQ(-3)+0.5D0*XPV
37674 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
37678 XPVAL(-1)=0.5D0*XPV
37680 XPVAL(-3)=0.5D0*XPV
37682 C...Isospin conjugation for neutron.
37683 ELSEIF(KFA.EQ.2112) THEN
37694 C...Simple recipes for hyperon (average valence parton distribution).
37695 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
37696 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
37697 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
37698 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
37703 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
37704 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
37705 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
37706 XPV=(XPVAL(1)+XPVAL(2))/3D0
37709 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
37710 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
37711 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
37714 C...Charge conjugation for antiparticle.
37717 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
37724 XPVAL(KFL)=XPVAL(-KFL)
37729 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
37732 C...Only reshape PDFs for the non-first interactions;
37733 C...But need valence/sea separation already from first interaction.
37734 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
37735 KFVSEL=KFIVAL(JS,1)
37736 C...If valence quark kicked out of pi0 or gamma then that decides
37737 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
37738 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
37741 XPVL=XPVL+XPVAL(KFL)
37742 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
37745 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
37746 XPVAL(IABS(KFVSEL))=XPVL
37749 XPVAL(-KFL)=XPVAL(KFL)
37752 C...If valence quark kicked out of K0S or K0S then that decides whether
37753 C...we should consider state as d sbar or s dbar.
37754 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
37756 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
37757 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37758 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37759 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37762 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37763 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37764 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37768 C...XPQ distributions are nominal for a (signed) beam particle
37769 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
37777 IF(IFL.EQ.0) GOTO 350
37779 C...Count up number of original IFL valence quarks.
37781 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
37782 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
37783 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
37784 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
37785 C...bookkeep as if d dbar (for total momentum sum in valence sector).
37786 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
37787 C...Count down number of remaining IFL valence quarks. Skip current
37788 C...interaction initiator.
37790 DO 330 I1=1,NMI(JS)
37791 IF (I1.EQ.MINT(36)) GOTO 330
37792 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
37796 C...Separate out original VALENCE and SEA content.
37798 SEA=MAX(0D0,XPQ(IFL)-VAL)
37802 C...Rescale valence content if changed.
37803 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
37804 & (VAL*IVREM)/IVORG
37806 C...Momentum integrals of original and removed valence quarks.
37807 IF(IVORG.NE.0) THEN
37808 C...For p/n/pbar/nbar beams can split into d_val and u_val.
37809 C...Isospin conjugation for neutrons
37810 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
37812 IF (KFA.EQ.2112) IAFLP=3-IAFLP
37813 VPAVG=PAVG(IAFLP,Q2)
37814 C...For other baryons average d_val and u_val, like for PDFs.
37815 ELSEIF(KFA.GT.1000) THEN
37816 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
37817 C...For mesons and photon average d_val and u_val and scale by 3/2.
37818 C...Very crude, especially for photon.
37820 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
37822 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
37823 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
37826 C...Now add companions (at X with partner having been at Z=XASSOC).
37827 C...NOTE: due to the assumed simple x scaling, the partner was at what
37828 C...corresponds to a higher Z than XASSOC, if there were intermediate
37829 C...scatterings. Nothing done about that for the moment.
37830 DO 340 IVC=1,NVC(JS,IFL)
37831 C...Skip companions that have been kicked out
37832 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
37836 C...Momentum fraction of the partner quark.
37837 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
37838 XS=XASSOC(JS,IFL,IVC)
37841 C...Momentum fraction of the companion quark.
37842 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
37844 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
37845 C...Add to momentum sum, with rescaling compensation factor.
37846 XCFAC=(XREM+XS)/XREM*CMPFAC
37847 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
37852 C...Wait until all flavours treated, then rescale seas and gluon.
37855 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
37856 IF (RSFAC.LE.0D0) THEN
37857 C...First calculate factor needed to exactly restore pz cons.
37858 IF (NRESC.EQ.1) CMPFAC =
37859 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
37860 C...Add a bit of headroom
37862 C...Try a few times if more headroom is needed, then print error message.
37863 IF (NRESC.LE.10) GOTO 345
37865 & '(PYPDFU:) Negative reshaping factor persists!')
37866 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
37870 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
37871 C...Also store resulting distributions in XPQ
37873 DO 360 ISVC=-1,NVC(JS,IFL)
37874 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
37877 C...Save companion reweighting factor for PYPTIS.
37882 C...Allow gluon also in position 21.
37885 C...Check positivity and reset above maximum allowed flavour.
37887 XPQ(KFL)=MAX(0D0,XPQ(KFL))
37888 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
37891 C...Formats for error printouts.
37892 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37893 5100 FORMAT(' Error: illegal particle code for parton distribution;',
37895 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
37897 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
37898 & ' Removed valence momentum fraction : ',F6.3/
37899 & ' Added companion momentum fraction : ',F6.3/
37900 & ' Resulting rescale factor : ',F6.3)
37902 C...Reset side pointer and return
37908 C*********************************************************************
37911 C...Gives proton parton distribution at small x and/or Q^2 according to
37912 C...correct limiting behaviour.
37914 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37916 C...Double precision and integer declarations.
37917 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37918 IMPLICIT INTEGER(I-N)
37919 INTEGER PYK,PYCHGE,PYCOMP
37921 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37922 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37923 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37924 COMMON/PYINT1/MINT(400),VINT(400)
37925 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37927 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37928 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37930 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37934 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37935 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37936 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37938 CALL PYPDFU(KF,X,Q2,XPQ)
37942 C...Reset. Check x.
37946 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37947 WRITE(MSTU(11),5000) X
37951 C...Define valence content.
37955 IF(KF.EQ.2212) THEN
37958 ELSEIF(KF.EQ.-2212) THEN
37961 ELSEIF(KF.EQ.2112) THEN
37964 ELSEIF(KF.EQ.-2112) THEN
37967 ELSEIF(KF.EQ.211) THEN
37971 ELSEIF(KF.EQ.-211) THEN
37975 ELSEIF(MINT(105).LE.223) THEN
37980 ELSEIF(MINT(105).EQ.333) THEN
37985 ELSEIF(MINT(105).EQ.443) THEN
37992 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
37994 CALL PYPDFU(KFC,X,Q2,XPA)
37995 Q2MN=MAX(3D0,VINT(231))
37996 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
37997 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
37999 C...Large Q2 and large x: naive call is enough.
38000 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38006 C...Small Q2 and large x: dampen boundary value.
38007 ELSEIF(X.GT.XMN) THEN
38009 C...Evaluate at boundary and define dampening factors.
38011 CALL PYPDFU(KFC,X,Q2MN,XPA)
38012 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38013 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38015 C...Separate valence and sea parts of parton distribution.
38017 XFV1=XPA(KFV1)-XPA(-KFV1)
38018 XPA(KFV1)=XPA(-KFV1)
38019 XFV2=XPA(KFV2)-XPA(-KFV2)
38020 XPA(KFV2)=XPA(-KFV2)
38022 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38023 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38024 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38025 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38028 C...Dampen valence and sea separately. Put back together.
38030 XPQ(KFL)=FS*XPA(KFL)
38033 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38034 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38036 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38037 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38038 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38039 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38043 C...Large Q2 and small x: interpolate behaviour.
38044 ELSEIF(Q2.GT.Q2MN) THEN
38046 C...Evaluate at extremes and define coefficients for interpolation.
38048 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38051 CALL PYPDFU(KFC,X,Q2B,XPB)
38053 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38054 FVA=(X/XMN)**0.45D0*FLA
38055 FSA=(X/XMN)**(-0.08D0)*FLA
38058 C...Separate valence and sea parts of parton distribution.
38060 XFVA1=XPA(KFV1)-XPA(-KFV1)
38061 XPA(KFV1)=XPA(-KFV1)
38062 XFVA2=XPA(KFV2)-XPA(-KFV2)
38063 XPA(KFV2)=XPA(-KFV2)
38064 XFVB1=XPB(KFV1)-XPB(-KFV1)
38065 XPB(KFV1)=XPB(-KFV1)
38066 XFVB2=XPB(KFV2)-XPB(-KFV2)
38067 XPB(KFV2)=XPB(-KFV2)
38069 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38070 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38071 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38072 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38073 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38074 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38075 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38076 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
38079 C...Interpolate for valence and sea. Put back together.
38081 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
38084 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
38085 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
38087 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38088 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38089 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38090 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38094 C...Small Q2 and small x: dampen boundary value and add term.
38097 C...Evaluate at boundary and define dampening factors.
38099 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38100 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
38102 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
38103 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
38104 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
38105 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
38106 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
38107 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
38109 C...Separate valence and sea parts of parton distribution.
38111 XFV1=XPA(KFV1)-XPA(-KFV1)
38112 XPA(KFV1)=XPA(-KFV1)
38113 XFV2=XPA(KFV2)-XPA(-KFV2)
38114 XPA(KFV2)=XPA(-KFV2)
38116 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38117 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38118 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38119 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38122 C...Dampen valence and sea separately. Add constant terms.
38123 C...Put back together.
38125 XPQ(KFL)=FSA*XPA(KFL)
38129 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
38131 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
38132 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
38135 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
38137 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38138 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38139 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38140 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38146 C...Format for error printout.
38147 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38152 C*********************************************************************
38155 C...Gives electron (or muon, or tau) parton distribution.
38157 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
38159 C...Double precision and integer declarations.
38160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38161 IMPLICIT INTEGER(I-N)
38162 INTEGER PYK,PYCHGE,PYCOMP
38164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38166 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38167 COMMON/PYINT1/MINT(400),VINT(400)
38168 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38170 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
38172 C...Interface to PDFLIB.
38173 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
38175 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38176 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38177 CHARACTER*20 PARM(20)
38178 DATA VALUE/20*0D0/,PARM/20*' '/
38180 C...Some common constants.
38186 IF(KFA.EQ.13) PME=PMAS(13,1)
38187 IF(KFA.EQ.15) PME=PMAS(15,1)
38188 XL=LOG(MAX(1D-10,X))
38189 X1L=LOG(MAX(1D-10,1D0-X))
38190 HLE=LOG(MAX(3D0,Q2/PME**2))
38191 HBE2=(AEM/PARU(1))*(HLE-1D0)
38193 C...Electron inside electron, see R. Kleiss et al., in Z physics at
38194 C...LEP 1, CERN 89-08, p. 34
38195 IF(MSTP(59).LE.1) THEN
38196 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
38197 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
38198 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
38199 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
38200 & 4D0*XL/(1D0-X)-5D0-X)
38202 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
38203 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
38204 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
38206 C...Zero distribution for very large x and rescale it for intermediate.
38207 IF(X.GT.1D0-1D-10) THEN
38209 ELSEIF(X.GT.1D0-1D-7) THEN
38210 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
38214 C...Photon and (transverse) W- inside electron.
38215 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
38216 IF(MSTP(13).LE.1) THEN
38219 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
38221 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
38222 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
38223 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
38225 C...Electron or positron inside photon inside electron.
38226 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
38227 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
38228 & 2D0*X*(1D0+X)*XL)
38229 XPEL(11)=XPEL(11)+XFSEA
38232 C...Initialize PDFLIB photon parton distributions.
38233 IF(MSTP(56).EQ.2) THEN
38237 VALUE(2)=MSTP(55)/1000
38239 VALUE(3)=MOD(MSTP(55),1000)
38240 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38241 CALL PDFSET(PARM,VALUE)
38242 MINT(93)=3000000+MSTP(55)
38246 C...Quarks and gluons inside photon inside electron:
38247 C...numerical convolution required.
38256 IF(ITER.EQ.0) NSTP=2
38258 SXP(KFL)=0.5D0*SXP(KFL)
38261 IF(ITER.EQ.0) WTSTP=0.5D0
38262 C...Pick grid of x_{gamma} values logarithmically even.
38267 XLE=XL*(ISTP-0.5D0)/NSTP
38269 XE=MIN(1D0-1D-10,EXP(XLE))
38270 XG=MIN(1D0-1D-10,X/XE)
38271 C...Evaluate photon inside electron parton distribution for convolution.
38272 XPGP=1D0+(1D0-XE)**2
38273 IF(MSTP(13).LE.1) THEN
38276 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
38278 C...Evaluate photon parton distributions for convolution.
38279 IF(MSTP(56).EQ.1) THEN
38280 IF(MSTP(55).EQ.1) THEN
38281 CALL PYPDGA(XG,Q2,XPGA)
38282 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38285 IF(MSTP(55).GE.7) P2MX=4.0D0
38286 IF(MSTP(57).EQ.0) Q2MX=P2MX
38288 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38289 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38291 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38294 IF(MSTP(55).GE.11) P2MX=4.0D0
38295 IF(MSTP(57).EQ.0) Q2MX=P2MX
38297 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38298 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38302 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
38304 ELSEIF(MSTP(56).EQ.2) THEN
38305 C...Call PDFLIB parton distributions.
38307 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38308 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38309 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38310 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
38311 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
38312 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
38313 SXP(3)=SXP(3)+WTSTP*XPGP*STR
38314 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
38315 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
38316 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
38319 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
38320 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
38321 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
38323 C...Put convolution into output arrays.
38325 XPEL(0)=FCONV*SXP(0)
38327 XPEL(KFL)=FCONV*SXP(KFL)
38328 XPEL(-KFL)=XPEL(KFL)
38335 C*********************************************************************
38338 C...Gives photon parton distribution.
38340 SUBROUTINE PYPDGA(X,Q2,XPGA)
38342 C...Double precision and integer declarations.
38343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38344 IMPLICIT INTEGER(I-N)
38345 INTEGER PYK,PYCHGE,PYCOMP
38347 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38348 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38349 COMMON/PYINT1/MINT(400),VINT(400)
38350 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38352 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
38353 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
38354 &DGCS(4,3),DGDS(4,3),DGES(4,3)
38356 C...The following data lines are coefficients needed in the
38357 C...Drees and Grassie photon parton distribution parametrization.
38358 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
38359 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
38360 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
38361 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
38362 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
38363 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
38364 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
38365 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
38366 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
38367 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
38368 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
38369 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
38370 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
38371 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
38372 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
38373 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
38374 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
38375 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
38376 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
38377 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
38378 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
38379 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
38380 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
38381 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
38382 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
38383 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
38385 C...Photon parton distribution from Drees and Grassie.
38386 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
38391 IF(MSTP(57).LE.0) THEN
38394 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
38398 IF(Q2.GT.25D0) NF=4
38399 IF(Q2.GT.300D0) NF=5
38403 C...Evaluate gluon content.
38404 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
38405 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
38406 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
38407 XPGL=DGA*X**DGB*X1**DGC
38409 C...Evaluate up- and down-type quark content.
38410 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
38411 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
38412 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
38413 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
38414 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
38415 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38416 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
38417 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
38418 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
38419 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
38420 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
38422 IF(NF.EQ.4) DGF=10D0
38423 IF(NF.EQ.5) DGF=55D0/6D0
38424 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38426 XPQU=(XPQS+9D0*XPQN)/6D0
38427 XPQD=(XPQS-4.5D0*XPQN)/6D0
38428 ELSEIF(NF.EQ.4) THEN
38429 XPQU=(XPQS+6D0*XPQN)/8D0
38430 XPQD=(XPQS-6D0*XPQN)/8D0
38432 XPQU=(XPQS+7.5D0*XPQN)/10D0
38433 XPQD=(XPQS-5D0*XPQN)/10D0
38436 C...Put into output arrays.
38441 IF(NF.GE.4) XPGA(4)=AEM*XPQU
38442 IF(NF.GE.5) XPGA(5)=AEM*XPQD
38444 XPGA(-KFL)=XPGA(KFL)
38450 C*********************************************************************
38453 C...Constructs the F2 and parton distributions of the photon
38454 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
38455 C...For F2, c and b are included by the Bethe-Heitler formula;
38456 C...in the 'MSbar' scheme additionally a Cgamma term is added.
38457 C...Contains the SaS sets 1D, 1M, 2D and 2M.
38458 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38460 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
38462 C...Double precision and integer declarations.
38463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38464 IMPLICIT INTEGER(I-N)
38465 INTEGER PYK,PYCHGE,PYCOMP
38467 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38469 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38470 SAVE /PYINT8/,/PYINT9/
38472 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
38473 C...Charm and bottom masses (low to compensate for J/psi etc.).
38474 DATA PMC/1.3D0/, PMB/4.6D0/
38475 C...alpha_em and alpha_em/(2*pi).
38476 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
38477 C...Lambda value for 4 flavours.
38479 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
38481 C...VMD couplings f_V**2/(4*pi).
38482 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
38483 C...Masses for rho (=omega) and phi.
38484 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
38485 C...Number of points in integration for IP2=1.
38503 C...Set Q0 cut-off parameter as function of set used.
38511 C...Scale choice for off-shell photon; common factors.
38516 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38517 FACNOR=LOG(Q2/Q02)/NSTEP
38518 ELSEIF(IP2.EQ.2) THEN
38520 ELSEIF(IP2.EQ.3) THEN
38522 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38523 ELSEIF(IP2.EQ.4) THEN
38524 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38525 & ((Q2+P2)*(Q02+P2)))
38526 ELSEIF(IP2.EQ.5) THEN
38527 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38528 & ((Q2+P2)*(Q02+P2)))
38529 P2MX=Q0*SQRT(P2MXA)
38530 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
38531 ELSEIF(IP2.EQ.6) THEN
38532 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38533 & ((Q2+P2)*(Q02+P2)))
38534 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38536 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38537 & ((Q2+P2)*(Q02+P2)))
38538 P2MX=Q0*SQRT(P2MXA)
38540 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38541 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
38542 IF(ABS(Q2-Q02).GT.1D-6) THEN
38543 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
38544 ELSEIF(P2.LT.Q02) THEN
38545 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
38551 C...Call VMD parametrization for d quark and use to give rho, omega,
38552 C...phi. Note dipole dampening for off-shell photon.
38553 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38557 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
38558 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
38560 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
38562 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
38563 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
38564 XPVMD(3)=XPVMD(3)+FACS*XFVAL
38565 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
38566 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
38567 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
38568 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
38569 VXPVMD(2)=FRACU*FACUD*XFVAL
38570 VXPVMD(3)=FACS*XFVAL
38571 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
38572 VXPVMD(-2)=FRACU*FACUD*XFVAL
38573 VXPVMD(-3)=FACS*XFVAL
38576 C...Anomalous parametrizations for different strategies
38577 C...for off-shell photons; except full integration.
38579 C...Call anomalous parametrization for d + u + s.
38580 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38582 XPANL(KFL)=FACNOR*XPGA(KFL)
38583 VXPANL(KFL)=FACNOR*VXPGA(KFL)
38586 C...Call anomalous parametrization for c and b.
38587 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38589 XPANH(KFL)=FACNOR*XPGA(KFL)
38590 VXPANH(KFL)=FACNOR*VXPGA(KFL)
38592 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38594 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
38595 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
38599 C...Special option: loop over flavours and integrate over k2.
38601 DO 160 ISTEP=1,NSTEP
38602 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
38603 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
38604 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
38605 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
38606 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
38607 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
38608 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
38610 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
38611 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
38612 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
38613 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
38619 C...Call Bethe-Heitler term expression for charm and bottom.
38620 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
38623 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
38627 C...For MSbar subtraction call C^gamma term expression for d, u, s.
38628 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
38629 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
38631 XPDIR(KFL)=XPGA(KFL)
38635 C...Store result in output array.
38638 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
38639 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38640 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
38641 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
38642 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
38648 C*********************************************************************
38651 C...Evaluates the VMD parton distributions of a photon,
38652 C...evolved homogeneously from an initial scale P2 to Q2.
38653 C...Does not include dipole suppression factor.
38654 C...ISET is parton distribution set, see above;
38655 C...additionally ISET=0 is used for the evolution of an anomalous photon
38656 C...which branched at a scale P2 and then evolved homogeneously to Q2.
38657 C...ALAM is the 4-flavour Lambda, which is automatically converted
38658 C...to 3- and 5-flavour equivalents as needed.
38659 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38661 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38663 C...Double precision and integer declarations.
38664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38665 IMPLICIT INTEGER(I-N)
38666 INTEGER PYK,PYCHGE,PYCOMP
38667 C...Local arrays and data.
38668 DIMENSION XPGA(-6:6), VXPGA(-6:6)
38669 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38678 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38679 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
38680 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
38681 P2EFF=MAX(P2,1.2D0*ALAM3**2)
38682 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38683 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38684 Q2EFF=MAX(Q2,P2EFF)
38686 C...Find number of flavours at lower and upper scale.
38688 IF(P2EFF.LT.PMC**2) NFP=3
38689 IF(P2EFF.GT.PMB**2) NFP=5
38691 IF(Q2EFF.LT.PMC**2) NFQ=3
38692 IF(Q2EFF.GT.PMB**2) NFQ=5
38694 C...Find s as sum of 3-, 4- and 5-flavour parts.
38698 IF(NFQ.EQ.3) Q2DIV=Q2EFF
38699 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
38701 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
38703 IF(NFP.EQ.3) P2DIV=PMC**2
38705 IF(NFQ.EQ.5) Q2DIV=PMB**2
38706 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
38710 IF(NFP.EQ.5) P2DIV=P2EFF
38711 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
38714 C...Calculate frequent combinations of x and s.
38721 C...Evaluate homogeneous anomalous parton distributions below or
38722 C...above threshold.
38724 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38725 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38726 XVAL = X * 1.5D0 * (X**2+X1**2)
38730 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
38731 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
38732 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
38733 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
38734 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
38735 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
38736 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
38737 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
38738 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
38739 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
38740 & (2D0*X-1D0)*X*XL**2)
38743 C...Evaluate set 1D parton distributions below or above threshold.
38744 ELSEIF(ISET.EQ.1) THEN
38745 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38746 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38747 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
38748 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
38749 XSEA = 0.100D0 * X1**3.76D0
38751 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
38752 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
38753 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
38754 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
38755 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
38756 & X**0.40D0 * X1**(1.76D0+3D0*S)
38757 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
38758 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
38759 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
38760 XSEA0 = 0.100D0 * X1**3.76D0
38763 C...Evaluate set 1M parton distributions below or above threshold.
38764 ELSEIF(ISET.EQ.2) THEN
38765 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38766 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38767 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
38768 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
38771 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
38772 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
38773 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
38774 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
38775 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
38776 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
38777 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
38778 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
38783 C...Evaluate set 2D parton distributions below or above threshold.
38784 ELSEIF(ISET.EQ.3) THEN
38785 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38786 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38787 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
38788 XGLU = 1.925D0 * X1**2
38789 XSEA = 0.242D0 * X1**4
38791 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
38792 & X**(0.46D0+0.25D0*S) *
38793 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
38794 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
38795 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
38796 & EXP(-18.67D0*S) *
38797 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
38798 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
38799 & XL**(9.3D0*S/(1D0+1.7D0*S))
38800 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
38801 & (1D0-0.607D0*S+21.95D0*S2) *
38802 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
38803 XSEA0 = 0.242D0 * X1**4
38806 C...Evaluate set 2M parton distributions below or above threshold.
38807 ELSEIF(ISET.EQ.4) THEN
38808 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38809 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38810 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
38811 XGLU = 1.808D0 * X1**2
38812 XSEA = 0.209D0 * X1**4
38814 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
38815 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
38816 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
38817 & XL**(5.15D0*S/(1D0+2D0*S)) +
38818 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
38819 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
38820 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
38821 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
38822 & XL**(10.9D0*S/(1D0+2.5D0*S))
38823 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
38824 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
38825 & X1**(4D0+S) * XL**(0.45D0*S)
38826 XSEA0 = 0.209D0 * X1**4
38830 C...Threshold factors for c and b sea.
38831 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38833 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38834 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38836 XCHM=XSEA*(1D0-(SCH/SLL)**2)
38838 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
38842 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38843 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38845 XBOT=XSEA*(1D0-(SBT/SLL)**2)
38847 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
38851 C...Fill parton distributions.
38858 XPGA(KFA)=XPGA(KFA)+XVAL
38860 XPGA(-KFL)=XPGA(KFL)
38868 C*********************************************************************
38871 C...Evaluates the parton distributions of the anomalous photon,
38872 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
38873 C...KF=0 gives the sum over (up to) 5 flavours,
38874 C...KF<0 limits to flavours up to abs(KF),
38875 C...KF>0 is for flavour KF only.
38876 C...ALAM is the 4-flavour Lambda, which is automatically converted
38877 C...to 3- and 5-flavour equivalents as needed.
38878 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38880 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38882 C...Double precision and integer declarations.
38883 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38884 IMPLICIT INTEGER(I-N)
38885 INTEGER PYK,PYCHGE,PYCOMP
38886 C...Local arrays and data.
38887 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
38888 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38895 IF(Q2.LE.P2) RETURN
38898 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38899 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
38901 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
38902 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
38903 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38904 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38905 Q2EFF=MAX(Q2,P2EFF)
38908 C...Find number of flavours at lower and upper scale.
38910 IF(P2EFF.LT.PMC**2) NFP=3
38911 IF(P2EFF.GT.PMB**2) NFP=5
38913 IF(Q2EFF.LT.PMC**2) NFQ=3
38914 IF(Q2EFF.GT.PMB**2) NFQ=5
38916 C...Define range of flavour loop.
38920 ELSEIF(KF.LT.0) THEN
38928 C...Loop over flavours the photon can branch into.
38929 DO 110 KFL=KFLMN,KFLMX
38931 C...Light flavours: calculate t range and (approximate) s range.
38932 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38933 TDIFF=LOG(Q2EFF/P2EFF)
38934 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38935 & LOG(P2EFF/ALAMSQ(NFQ)))
38936 IF(NFQ.GT.NFP) THEN
38938 IF(NFQ.EQ.4) Q2DIV=PMC**2
38939 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38940 & LOG(P2EFF/ALAMSQ(NFQ)))
38941 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38942 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38943 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38945 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38947 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38948 & LOG(P2EFF/ALAMSQ(4)))
38949 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38950 & LOG(P2EFF/ALAMSQ(3)))
38951 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38954 C...u and s quark do not need a separate treatment when d has been done.
38955 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38957 C...Charm: as above, but only include range above c threshold.
38958 ELSEIF(KFL.EQ.4) THEN
38959 IF(Q2.LE.PMC**2) GOTO 110
38960 P2EFF=MAX(P2EFF,PMC**2)
38961 Q2EFF=MAX(Q2EFF,P2EFF)
38962 TDIFF=LOG(Q2EFF/P2EFF)
38963 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38964 & LOG(P2EFF/ALAMSQ(NFQ)))
38965 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38967 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38968 & LOG(P2EFF/ALAMSQ(NFQ)))
38969 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38970 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38971 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38974 C...Bottom: as above, but only include range above b threshold.
38975 ELSEIF(KFL.EQ.5) THEN
38976 IF(Q2.LE.PMB**2) GOTO 110
38977 P2EFF=MAX(P2EFF,PMB**2)
38978 Q2EFF=MAX(Q2,P2EFF)
38979 TDIFF=LOG(Q2EFF/P2EFF)
38980 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38981 & LOG(P2EFF/ALAMSQ(NFQ)))
38984 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
38986 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
38987 FAC=AEM2PI*2D0*CHSQ*TDIFF
38989 C...Evaluate parton distributions (normalized to unit momentum sum).
38990 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
38991 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
38992 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
38993 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
38994 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
38995 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
38996 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
38997 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
38998 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
38999 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39000 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39001 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39003 C...Threshold factors for c and b sea.
39004 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39006 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39007 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39008 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39011 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39012 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39013 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39017 C...Add contribution of each valence flavour.
39018 XPGA(0)=XPGA(0)+FAC*XGLU
39019 XPGA(1)=XPGA(1)+FAC*XSEA
39020 XPGA(2)=XPGA(2)+FAC*XSEA
39021 XPGA(3)=XPGA(3)+FAC*XSEA
39022 XPGA(4)=XPGA(4)+FAC*XCHM
39023 XPGA(5)=XPGA(5)+FAC*XBOT
39024 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39025 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39028 XPGA(-KFL)=XPGA(KFL)
39029 VXPGA(-KFL)=VXPGA(KFL)
39036 C*********************************************************************
39039 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39041 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39043 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39045 C...Double precision and integer declarations.
39046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39047 IMPLICIT INTEGER(I-N)
39048 INTEGER PYK,PYCHGE,PYCOMP
39051 DATA AEM2PI/0.0011614D0/
39057 C...Check kinematics limits.
39058 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39060 BETA2=1D0-4D0*PM2/W2
39061 IF(BETA2.LT.1D-10) RETURN
39065 C...Simple case: P2 = 0.
39066 IF(P2.LT.1D-4) THEN
39067 IF(BETA.LT.0.99D0) THEN
39068 XBL=LOG((1D0+BETA)/(1D0-BETA))
39070 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39072 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39073 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39075 C...Complicated case: P2 > 0, based on approximation of
39076 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39078 RPQ=1D0-4D0*X**2*P2/Q2
39079 IF(RPQ.GT.1D-10) THEN
39080 RPBE=SQRT(RPQ*BETA2)
39081 IF(RPBE.LT.0.99D0) THEN
39082 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
39083 XBI=2D0*RPBE/(1D0-RPBE**2)
39085 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
39086 XBL=LOG((1D0+RPBE)**2/RPBESN)
39087 XBI=2D0*RPBE/RPBESN
39089 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
39090 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
39091 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
39095 C...Multiply by charge-squared etc. to get parton distribution.
39097 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
39098 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
39103 C*********************************************************************
39106 C...Evaluates the direct contribution, i.e. the C^gamma term,
39107 C...as needed in MSbar parametrizations.
39108 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39110 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
39112 C...Double precision and integer declarations.
39113 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39114 IMPLICIT INTEGER(I-N)
39115 INTEGER PYK,PYCHGE,PYCOMP
39116 C...Local array and data.
39117 DIMENSION XPGA(-6:6)
39118 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
39125 C...Evaluate common x-dependent expression.
39126 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
39127 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
39129 C...d, u, s part by simple charge factor.
39130 XPGA(1)=(1D0/9D0)*CGAM
39131 XPGA(2)=(4D0/9D0)*CGAM
39132 XPGA(3)=(1D0/9D0)*CGAM
39134 C...Also fill for antiquarks.
39142 C*********************************************************************
39145 C...Gives pi+ parton distribution according to two different
39146 C...parametrizations.
39148 SUBROUTINE PYPDPI(X,Q2,XPPI)
39150 C...Double precision and integer declarations.
39151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39152 IMPLICIT INTEGER(I-N)
39153 INTEGER PYK,PYCHGE,PYCOMP
39155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39156 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39157 COMMON/PYINT1/MINT(400),VINT(400)
39158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39160 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
39162 C...The following data lines are coefficients needed in the
39163 C...Owens pion parton distribution parametrizations, see below.
39164 C...Expansion coefficients for up and down valence quark distributions.
39165 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
39166 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39167 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39168 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39169 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
39170 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39171 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39172 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39173 C...Expansion coefficients for gluon distribution.
39174 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
39175 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
39176 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
39177 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
39178 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
39179 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
39180 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
39181 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
39182 C...Expansion coefficients for (up+down+strange) quark sea distribution.
39183 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
39184 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39185 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
39186 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
39187 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
39188 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39189 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
39190 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
39191 C...Expansion coefficients for charm quark sea distribution.
39192 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
39193 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
39194 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
39195 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
39196 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
39197 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
39198 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
39199 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
39201 C...Euler's beta function, requires ordinary Gamma function
39202 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
39204 C...Reset output array.
39209 IF(MSTP(53).LE.2) THEN
39210 C...Pion parton distributions from Owens.
39211 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
39213 C...Determine set, Lambda and s expansion variable.
39215 IF(NSET.EQ.1) ALAM=0.2D0
39216 IF(NSET.EQ.2) ALAM=0.4D0
39218 IF(MSTP(57).LE.0) THEN
39221 Q2IN=MIN(2D3,MAX(4D0,Q2))
39222 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
39225 C...Calculate parton distributions.
39228 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
39229 & COW(3,IS,KFL,NSET)*SD**2
39232 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
39234 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
39239 C...Put into output array.
39242 XPPI(2)=XQ(1)+XQ(3)/6D0
39245 XPPI(-1)=XQ(1)+XQ(3)/6D0
39250 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
39251 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
39255 C...Determine s expansion variable and some x expressions.
39257 IF(MSTP(57).LE.0) THEN
39260 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
39261 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
39267 C...Evaluate valence, gluon and sea distributions.
39268 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
39269 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
39270 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
39272 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
39273 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
39275 & (1D0-X)**(0.390D0+1.053D0*SD)
39276 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
39278 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
39280 & XL**(2.538D0-0.763D0*SD)
39281 IF(SD.LE.0.888D0) THEN
39284 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
39286 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
39289 IF(SD.LE.1.351D0) THEN
39292 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
39293 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
39297 C...Put into output array.
39305 XPPI(-KFL)=XPPI(KFL)
39307 XPPI(2)=XPPI(2)+XFVAL
39308 XPPI(-1)=XPPI(-1)+XFVAL
39314 C*********************************************************************
39317 C...Gives proton parton distributions according to a few different
39318 C...parametrizations.
39320 SUBROUTINE PYPDPR(X,Q2,XPPR)
39322 C...Double precision and integer declarations.
39323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39324 IMPLICIT INTEGER(I-N)
39325 INTEGER PYK,PYCHGE,PYCOMP
39327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39329 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39330 COMMON/PYINT1/MINT(400),VINT(400)
39331 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39332 C...Arrays and data.
39333 DIMENSION XPPR(-6:6),Q2MIN(16)
39334 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
39335 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
39337 C...Reset output array.
39342 C...Common preliminaries.
39343 NSET=MAX(1,MIN(16,MSTP(51)))
39344 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
39345 VINT(231)=Q2MIN(NSET)
39346 IF(MSTP(57).EQ.0) THEN
39349 Q2L=MAX(Q2MIN(NSET),Q2)
39352 IF(NSET.GE.1.AND.NSET.LE.3) THEN
39353 C...Interface to the CTEQ 3 parton distributions.
39354 QRT=SQRT(MAX(1D0,Q2L))
39356 C...Loop over flavours.
39359 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
39360 ELSEIF(I.LE.2) THEN
39361 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
39367 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
39368 C...Interface to the GRV 94 distributions.
39370 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39371 ELSEIF(NSET.EQ.5) THEN
39372 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39374 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39377 C...Put into output array.
39379 XPPR(-1)=0.5D0*(UDB+DEL)
39380 XPPR(-2)=0.5D0*(UDB-DEL)
39384 XPPR(1)=DV+XPPR(-1)
39385 XPPR(2)=UV+XPPR(-2)
39390 ELSEIF(NSET.EQ.7) THEN
39391 C...Interface to the CTEQ 5L parton distributions.
39392 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
39393 C...freezing x*f(x,Q2) at borders.
39394 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39395 XIN=MAX(1D-6,MIN(1D0,X))
39397 C...Loop over flavours (with u <-> d notation mismatch).
39398 SUMUDB=PYCT5L(-1,XIN,QRT)
39399 RATUDB=PYCT5L(-2,XIN,QRT)
39402 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
39403 ELSEIF(I.EQ.2) THEN
39404 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
39405 ELSEIF(I.EQ.-1) THEN
39406 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39407 ELSEIF(I.EQ.-2) THEN
39408 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39410 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
39411 IF(I.LT.0) XPPR(-I)=XPPR(I)
39415 ELSEIF(NSET.EQ.8) THEN
39416 C...Interface to the CTEQ 5M1 parton distributions.
39417 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39418 XIN=MAX(1D-6,MIN(1D0,X))
39420 C...Loop over flavours (with u <-> d notation mismatch).
39421 SUMUDB=PYCT5M(-1,XIN,QRT)
39422 RATUDB=PYCT5M(-2,XIN,QRT)
39425 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
39426 ELSEIF(I.EQ.2) THEN
39427 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
39428 ELSEIF(I.EQ.-1) THEN
39429 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39430 ELSEIF(I.EQ.-2) THEN
39431 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39433 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
39434 IF(I.LT.0) XPPR(-I)=XPPR(I)
39438 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
39439 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
39440 C...obsolete but offers backwards compatibility.
39441 CALL PYPDPO(X,Q2L,XPPR)
39443 C...Symmetric choice for debugging only
39444 ELSEIF(NSET.EQ.16) THEN
39462 C*********************************************************************
39465 C...Gives the CTEQ 3 parton distribution function sets in
39466 C...parametrized form, of October 24, 1994.
39467 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
39468 C...J. Qiu, W.K. Tung and H. Weerts.
39470 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
39472 C...Double precision declaration.
39473 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39474 IMPLICIT INTEGER(I-N)
39476 C...Data on Lambda values of fits, minimum Q and quark masses.
39477 DIMENSION ALM(3), QMS(4:6)
39478 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
39479 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
39481 C....Check flavour thresholds. Set up QI for SB.
39484 IF(Q .LE. QMS(IP)) THEN
39493 C...Use "standard lambda" of parametrization program for expansion.
39495 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
39500 C...Expansion for CTEQ3L.
39501 IF(ISET .EQ. 1) THEN
39502 IF(IPRT .EQ. 2) THEN
39503 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
39505 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
39506 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
39507 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
39508 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
39509 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
39510 ELSEIF(IPRT .EQ. 1) THEN
39511 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
39513 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
39514 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
39515 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
39516 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
39517 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
39518 ELSEIF(IPRT .EQ. 0) THEN
39519 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
39521 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
39522 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
39523 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
39524 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
39525 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
39526 ELSEIF(IPRT .EQ. -1) THEN
39527 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
39529 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
39530 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
39531 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
39532 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
39533 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
39534 ELSEIF(IPRT .EQ. -2) THEN
39535 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
39537 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
39538 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
39539 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
39540 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
39541 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
39542 ELSEIF(IPRT .EQ. -3) THEN
39543 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
39545 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
39546 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
39547 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
39548 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
39549 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
39550 ELSEIF(IPRT .EQ. -4) THEN
39551 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
39553 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
39554 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
39555 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
39556 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
39557 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
39558 ELSEIF(IPRT .EQ. -5) THEN
39559 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
39561 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
39562 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
39563 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
39564 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
39565 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
39566 ELSEIF(IPRT .EQ. -6) THEN
39567 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
39569 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
39570 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
39571 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
39572 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
39573 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
39576 C...Expansion for CTEQ3M.
39577 ELSEIF(ISET .EQ. 2) THEN
39578 IF(IPRT .EQ. 2) THEN
39579 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
39581 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
39582 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
39583 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
39584 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
39585 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
39586 ELSEIF(IPRT .EQ. 1) THEN
39587 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
39589 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
39590 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
39591 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
39592 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
39593 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
39594 ELSEIF(IPRT .EQ. 0) THEN
39595 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
39597 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
39598 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
39599 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
39600 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
39601 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
39602 ELSEIF(IPRT .EQ. -1) THEN
39603 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
39605 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
39606 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
39607 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
39608 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
39609 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
39610 ELSEIF(IPRT .EQ. -2) THEN
39611 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
39613 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
39614 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
39615 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
39616 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
39617 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
39618 ELSEIF(IPRT .EQ. -3) THEN
39619 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
39621 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
39622 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
39623 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
39624 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
39625 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
39626 ELSEIF(IPRT .EQ. -4) THEN
39627 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
39629 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
39630 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
39631 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
39632 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
39633 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
39634 ELSEIF(IPRT .EQ. -5) THEN
39635 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
39637 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
39638 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
39639 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
39640 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
39641 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
39642 ELSEIF(IPRT .EQ. -6) THEN
39643 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
39645 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
39646 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
39647 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
39648 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
39649 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
39652 C...Expansion for CTEQ3D.
39653 ELSEIF(ISET .EQ. 3) THEN
39654 IF(IPRT .EQ. 2) THEN
39655 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
39657 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
39658 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
39659 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
39660 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
39661 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
39662 ELSEIF(IPRT .EQ. 1) THEN
39663 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
39665 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
39666 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
39667 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
39668 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
39669 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
39670 ELSEIF(IPRT .EQ. 0) THEN
39671 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
39673 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
39674 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
39675 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
39676 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
39677 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
39678 ELSEIF(IPRT .EQ. -1) THEN
39679 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
39681 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
39682 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
39683 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
39684 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
39685 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
39686 ELSEIF(IPRT .EQ. -2) THEN
39687 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
39689 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
39690 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
39691 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
39692 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
39693 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
39694 ELSEIF(IPRT .EQ. -3) THEN
39695 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
39697 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
39698 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
39699 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
39700 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
39701 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
39702 ELSEIF(IPRT .EQ. -4) THEN
39703 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
39705 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
39706 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
39707 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
39708 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
39709 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
39710 ELSEIF(IPRT .EQ. -5) THEN
39711 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
39713 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
39714 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
39715 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
39716 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
39717 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
39718 ELSEIF(IPRT .EQ. -6) THEN
39719 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
39721 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
39722 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
39723 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
39724 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
39725 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
39729 C...Calculation of x * f(x, Q).
39730 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
39731 & *(LOG(1D0+1D0/X))**A5 )
39736 C*********************************************************************
39739 C...Gives the GRV 94 L (leading order) parton distribution function set
39740 C...in parametrized form.
39741 C...Authors: M. Glueck, E. Reya and A. Vogt.
39743 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39745 C...Double precision declaration.
39746 IMPLICIT DOUBLE PRECISION (A - Z)
39748 C...Common expressions.
39750 LAM2 = 0.2322D0 * 0.2322D0
39751 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39757 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
39758 AKU = 0.590D0 - 0.024D0 * S
39759 BKU = 0.131D0 + 0.063D0 * S
39760 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
39761 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
39762 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
39763 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
39764 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39767 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
39769 BKD = 0.486D0 + 0.062D0 * S
39770 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
39771 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
39772 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
39773 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
39774 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39777 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
39778 AKE = 0.409D0 - 0.005D0 * S
39779 BKE = 0.799D0 + 0.071D0 * S
39780 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
39781 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
39783 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
39784 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39789 AKX = 0.410D0 - 0.232D0 * S
39790 BKX = 0.534D0 - 0.457D0 * S
39791 AGX = 0.890D0 - 0.140D0 * S
39793 CX = 0.320D0 + 0.683D0 * S
39794 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
39795 EX = 4.119D0 + 1.713D0 * S
39796 ESX = 0.682D0 + 2.978D0 * S
39797 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39804 AKS = 1.798D0 - 0.596D0 * S
39805 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
39806 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
39807 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
39808 EST = 3.981D0 + 1.638D0 * S
39810 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39818 BC = 4.24D0 - 0.804D0 * S
39819 DCT = 3.46D0 - 1.076D0 * S
39820 ECT = 4.61D0 + 1.49D0 * S
39821 ESC = 2.555D0 + 1.961D0 * S
39822 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39831 DBT = 2.929D0 + 1.396D0 * S
39832 EBT = 4.71D0 + 1.514D0 * S
39833 ESB = 4.02D0 + 1.239D0 * S
39834 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39839 AKG = 1.742D0 - 0.930D0 * S
39840 BKG = - 0.399D0 * S2
39841 AG = 7.486D0 - 2.185D0 * S
39842 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
39843 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
39844 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
39845 EG = 0.807D0 + 2.005D0 * S
39846 ESG = 3.841D0 + 0.316D0 * S
39847 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
39853 C*********************************************************************
39856 C...Gives the GRV 94 M (MSbar) parton distribution function set
39857 C...in parametrized form.
39858 C...Authors: M. Glueck, E. Reya and A. Vogt.
39860 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39862 C...Double precision declaration.
39863 IMPLICIT DOUBLE PRECISION (A - Z)
39865 C...Common expressions.
39867 LAM2 = 0.248D0 * 0.248D0
39868 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39874 NU = 1.304D0 + 0.863D0 * S
39875 AKU = 0.558D0 - 0.020D0 * S
39877 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
39878 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
39879 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
39880 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
39881 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39884 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
39885 AKD = 0.270D0 - 0.019D0 * S
39887 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
39888 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
39889 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
39890 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
39891 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39894 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
39895 AKE = 0.409D0 - 0.007D0 * S
39896 BKE = 0.782D0 + 0.082D0 * S
39897 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
39898 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
39900 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
39901 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39909 BGX = 3.210D0 - 1.866D0 * S
39911 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39912 EX = 3.077D0 + 1.446D0 * S
39913 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39914 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39921 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39922 AS = -4.329D0 + 1.131D0 * S
39923 BS = 9.568D0 - 1.744D0 * S
39924 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39925 EST = 3.031D0 + 1.639D0 * S
39926 ESS = 5.837D0 + 0.815D0 * S
39927 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39933 AKC = -0.625D0 - 0.523D0 * S
39935 BC = 1.896D0 + 1.616D0 * S
39936 DCT = 4.12D0 + 0.683D0 * S
39937 ECT = 4.36D0 + 1.328D0 * S
39938 ESC = 0.677D0 + 0.679D0 * S
39939 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39945 AKB = - 0.193D0 * S
39948 DBT = 3.447D0 + 0.927D0 * S
39949 EBT = 4.68D0 + 1.259D0 * S
39950 ESB = 1.892D0 + 2.199D0 * S
39951 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39956 AKG = 1.724D0 + 0.157D0 * S
39957 BKG = 0.800D0 + 1.016D0 * S
39958 AG = 7.517D0 - 2.547D0 * S
39959 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39960 CG = 4.039D0 + 1.491D0 * S
39961 DG = 3.404D0 + 0.830D0 * S
39962 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39963 ESG = 3.256D0 - 0.436D0 * S
39964 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39969 C*********************************************************************
39972 C...Gives the GRV 94 D (DIS) parton distribution function set
39973 C...in parametrized form.
39974 C...Authors: M. Glueck, E. Reya and A. Vogt.
39976 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39978 C...Double precision declaration.
39979 IMPLICIT DOUBLE PRECISION (A - Z)
39981 C...Common expressions.
39983 LAM2 = 0.248D0 * 0.248D0
39984 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39990 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
39991 AKU = 0.563D0 - 0.025D0 * S
39992 BKU = 0.054D0 + 0.154D0 * S
39993 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
39994 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
39995 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
39996 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
39997 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40000 ND = 0.156D0 - 0.017D0 * S
40001 AKD = 0.299D0 - 0.022D0 * S
40002 BKD = 0.259D0 - 0.015D0 * S
40003 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40004 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40005 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40006 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40007 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40010 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40011 AKE = 0.419D0 - 0.013D0 * S
40012 BKE = 1.064D0 - 0.038D0 * S
40013 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40014 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40015 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40016 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40017 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40022 AKX = 0.326D0 + 0.150D0 * S
40023 BKX = 0.956D0 + 0.405D0 * S
40025 BGX = 3.794D0 - 2.359D0 * DS
40027 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40028 EX = 3.049D0 + 1.597D0 * S
40029 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40030 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40037 AKS = 1.415D0 - 0.641D0 * DS
40038 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40039 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40040 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40041 EST = 4.546D0 + 0.372D0 * S2
40042 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40043 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40049 AKC = -0.625D0 - 0.523D0 * S
40051 BC = 1.896D0 + 1.616D0 * S
40052 DCT = 4.12D0 + 0.683D0 * S
40053 ECT = 4.36D0 + 1.328D0 * S
40054 ESC = 0.677D0 + 0.679D0 * S
40055 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40061 AKB = - 0.193D0 * S
40064 DBT = 3.447D0 + 0.927D0 * S
40065 EBT = 4.68D0 + 1.259D0 * S
40066 ESB = 1.892D0 + 2.199D0 * S
40067 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40073 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40074 AG = 25.09D0 - 7.935D0 * S
40075 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
40076 CG = 590.3D0 - 173.8D0 * S
40077 DG = 5.196D0 + 1.857D0 * S
40078 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
40079 ESG = 3.232D0 - 0.542D0 * S
40080 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40085 C*********************************************************************
40088 C...Auxiliary for the GRV 94 parton distribution functions
40089 C...for u and d valence and d-u sea.
40090 C...Authors: M. Glueck, E. Reya and A. Vogt.
40092 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
40094 C...Double precision declaration.
40095 IMPLICIT DOUBLE PRECISION (A - Z)
40099 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
40105 C*********************************************************************
40108 C...Auxiliary for the GRV 94 parton distribution functions
40109 C...for d+u sea and gluon.
40110 C...Authors: M. Glueck, E. Reya and A. Vogt.
40112 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40114 C...Double precision declaration.
40115 IMPLICIT DOUBLE PRECISION (A - Z)
40119 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
40120 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
40125 C*********************************************************************
40128 C...Auxiliary for the GRV 94 parton distribution functions
40129 C...for s, c and b sea.
40130 C...Authors: M. Glueck, E. Reya and A. Vogt.
40132 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40134 C...Double precision declaration.
40135 IMPLICIT DOUBLE PRECISION (A - Z)
40143 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
40144 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
40150 C*********************************************************************
40153 C...Auxiliary function for parametrization of CTEQ5L.
40154 C...Author: J. Pumplin 9/99.
40156 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40157 C...in Parametrized Form
40158 C... September 15, 1999
40160 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40161 C... CTEQ5 PPARTON DISTRIBUTIONS"
40164 C...The CTEQ5M1 set given here is an updated version of the original
40165 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40166 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40167 C...almost all applications.
40168 C...The improvement is in the QCD evolution which is now more
40169 C...accurate, and which agrees completely with the benchmark work
40170 C...of the HERA 96/97 Workshop.
40171 C...The differences between the parametrized and the corresponding
40172 C...table versions (on which it is based) are of similar order as
40173 C...between the two version.
40175 C...!! Because accurate parametrizations over a wide range of (x,Q)
40176 C...is hard to obtain, only the most widely used sets CTEQ5M and
40177 C...CTEQ5L are available in parametrized form for now.
40179 C...These parametrizations were obtained by Jon Pumplin.
40181 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
40182 C -------------------------------------------------------------------
40183 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
40184 C 3 CTEQ5L Leading Order 0.127 192 146
40185 C -------------------------------------------------------------------
40186 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
40187 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
40190 C...The two Iset value are adopted to agree with the standard table
40193 C...Range of validity:
40194 C...The range of (x, Q) covered by this parametrization of the QCD
40195 C...evolved parton distributions is 1E-6 < x < 1 ;
40196 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
40197 C...data only in a subset of that region; and the assumed DGLAP
40198 C...evolution is unlikely to be valid for all of it either.
40200 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
40201 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
40202 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
40203 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
40205 FUNCTION PYCT5L(IFL,X,Q)
40207 C...Double precision declaration.
40208 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40209 IMPLICIT INTEGER(I-N)
40211 PARAMETER (NEX=8, NLF=2)
40212 DIMENSION AM(0:NEX,0:NLF,-5:2)
40213 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40214 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40215 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40216 DIMENSION AF(0:NEX)
40218 DATA MEXVEC( 2) / 8 /
40219 DATA MLFVEC( 2) / 2 /
40220 DATA UT1VEC( 2) / 0.4971265E+01 /
40221 DATA UT2VEC( 2) / -0.1105128E+01 /
40222 DATA ALFVEC( 2) / 0.2987216E+00 /
40223 DATA QMAVEC( 2) / 0.0000000E+00 /
40224 DATA (AM( 0,K, 2),K=0, 2)
40225 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
40226 DATA (AM( 1,K, 2),K=0, 2)
40227 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
40228 DATA (AM( 2,K, 2),K=0, 2)
40229 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
40230 DATA (AM( 3,K, 2),K=0, 2)
40231 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
40232 DATA (AM( 4,K, 2),K=0, 2)
40233 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
40234 DATA (AM( 5,K, 2),K=0, 2)
40235 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
40236 DATA (AM( 6,K, 2),K=0, 2)
40237 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
40238 DATA (AM( 7,K, 2),K=0, 2)
40239 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
40240 DATA (AM( 8,K, 2),K=0, 2)
40241 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
40243 DATA MEXVEC( 1) / 8 /
40244 DATA MLFVEC( 1) / 2 /
40245 DATA UT1VEC( 1) / 0.2612618E+01 /
40246 DATA UT2VEC( 1) / -0.1258304E+06 /
40247 DATA ALFVEC( 1) / 0.3407552E+00 /
40248 DATA QMAVEC( 1) / 0.0000000E+00 /
40249 DATA (AM( 0,K, 1),K=0, 2)
40250 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
40251 DATA (AM( 1,K, 1),K=0, 2)
40252 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
40253 DATA (AM( 2,K, 1),K=0, 2)
40254 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
40255 DATA (AM( 3,K, 1),K=0, 2)
40256 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
40257 DATA (AM( 4,K, 1),K=0, 2)
40258 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
40259 DATA (AM( 5,K, 1),K=0, 2)
40260 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
40261 DATA (AM( 6,K, 1),K=0, 2)
40262 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
40263 DATA (AM( 7,K, 1),K=0, 2)
40264 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
40265 DATA (AM( 8,K, 1),K=0, 2)
40266 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
40268 DATA MEXVEC( 0) / 8 /
40269 DATA MLFVEC( 0) / 2 /
40270 DATA UT1VEC( 0) / -0.4656819E+00 /
40271 DATA UT2VEC( 0) / -0.2742390E+03 /
40272 DATA ALFVEC( 0) / 0.4491863E+00 /
40273 DATA QMAVEC( 0) / 0.0000000E+00 /
40274 DATA (AM( 0,K, 0),K=0, 2)
40275 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
40276 DATA (AM( 1,K, 0),K=0, 2)
40277 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
40278 DATA (AM( 2,K, 0),K=0, 2)
40279 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
40280 DATA (AM( 3,K, 0),K=0, 2)
40281 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
40282 DATA (AM( 4,K, 0),K=0, 2)
40283 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
40284 DATA (AM( 5,K, 0),K=0, 2)
40285 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
40286 DATA (AM( 6,K, 0),K=0, 2)
40287 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
40288 DATA (AM( 7,K, 0),K=0, 2)
40289 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
40290 DATA (AM( 8,K, 0),K=0, 2)
40291 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
40293 DATA MEXVEC(-1) / 8 /
40294 DATA MLFVEC(-1) / 2 /
40295 DATA UT1VEC(-1) / 0.3862583E+01 /
40296 DATA UT2VEC(-1) / -0.1265969E+01 /
40297 DATA ALFVEC(-1) / 0.2457668E+00 /
40298 DATA QMAVEC(-1) / 0.0000000E+00 /
40299 DATA (AM( 0,K,-1),K=0, 2)
40300 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
40301 DATA (AM( 1,K,-1),K=0, 2)
40302 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
40303 DATA (AM( 2,K,-1),K=0, 2)
40304 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
40305 DATA (AM( 3,K,-1),K=0, 2)
40306 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
40307 DATA (AM( 4,K,-1),K=0, 2)
40308 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
40309 DATA (AM( 5,K,-1),K=0, 2)
40310 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
40311 DATA (AM( 6,K,-1),K=0, 2)
40312 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
40313 DATA (AM( 7,K,-1),K=0, 2)
40314 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
40315 DATA (AM( 8,K,-1),K=0, 2)
40316 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
40318 DATA MEXVEC(-2) / 7 /
40319 DATA MLFVEC(-2) / 2 /
40320 DATA UT1VEC(-2) / 0.1895615E+00 /
40321 DATA UT2VEC(-2) / -0.3069097E+01 /
40322 DATA ALFVEC(-2) / 0.5293999E+00 /
40323 DATA QMAVEC(-2) / 0.0000000E+00 /
40324 DATA (AM( 0,K,-2),K=0, 2)
40325 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
40326 DATA (AM( 1,K,-2),K=0, 2)
40327 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
40328 DATA (AM( 2,K,-2),K=0, 2)
40329 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
40330 DATA (AM( 3,K,-2),K=0, 2)
40331 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
40332 DATA (AM( 4,K,-2),K=0, 2)
40333 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
40334 DATA (AM( 5,K,-2),K=0, 2)
40335 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
40336 DATA (AM( 6,K,-2),K=0, 2)
40337 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
40338 DATA (AM( 7,K,-2),K=0, 2)
40339 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
40341 DATA MEXVEC(-3) / 7 /
40342 DATA MLFVEC(-3) / 2 /
40343 DATA UT1VEC(-3) / 0.3753257E+01 /
40344 DATA UT2VEC(-3) / -0.1113085E+01 /
40345 DATA ALFVEC(-3) / 0.3713141E+00 /
40346 DATA QMAVEC(-3) / 0.0000000E+00 /
40347 DATA (AM( 0,K,-3),K=0, 2)
40348 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
40349 DATA (AM( 1,K,-3),K=0, 2)
40350 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
40351 DATA (AM( 2,K,-3),K=0, 2)
40352 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
40353 DATA (AM( 3,K,-3),K=0, 2)
40354 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
40355 DATA (AM( 4,K,-3),K=0, 2)
40356 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
40357 DATA (AM( 5,K,-3),K=0, 2)
40358 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
40359 DATA (AM( 6,K,-3),K=0, 2)
40360 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
40361 DATA (AM( 7,K,-3),K=0, 2)
40362 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
40364 DATA MEXVEC(-4) / 7 /
40365 DATA MLFVEC(-4) / 2 /
40366 DATA UT1VEC(-4) / 0.4400772E+01 /
40367 DATA UT2VEC(-4) / -0.1356116E+01 /
40368 DATA ALFVEC(-4) / 0.3712017E-01 /
40369 DATA QMAVEC(-4) / 0.1300000E+01 /
40370 DATA (AM( 0,K,-4),K=0, 2)
40371 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
40372 DATA (AM( 1,K,-4),K=0, 2)
40373 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
40374 DATA (AM( 2,K,-4),K=0, 2)
40375 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
40376 DATA (AM( 3,K,-4),K=0, 2)
40377 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
40378 DATA (AM( 4,K,-4),K=0, 2)
40379 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
40380 DATA (AM( 5,K,-4),K=0, 2)
40381 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
40382 DATA (AM( 6,K,-4),K=0, 2)
40383 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
40384 DATA (AM( 7,K,-4),K=0, 2)
40385 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
40387 DATA MEXVEC(-5) / 6 /
40388 DATA MLFVEC(-5) / 2 /
40389 DATA UT1VEC(-5) / 0.5562568E+01 /
40390 DATA UT2VEC(-5) / -0.1801317E+01 /
40391 DATA ALFVEC(-5) / 0.4952010E-02 /
40392 DATA QMAVEC(-5) / 0.4500000E+01 /
40393 DATA (AM( 0,K,-5),K=0, 2)
40394 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
40395 DATA (AM( 1,K,-5),K=0, 2)
40396 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
40397 DATA (AM( 2,K,-5),K=0, 2)
40398 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
40399 DATA (AM( 3,K,-5),K=0, 2)
40400 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
40401 DATA (AM( 4,K,-5),K=0, 2)
40402 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
40403 DATA (AM( 5,K,-5),K=0, 2)
40404 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
40405 DATA (AM( 6,K,-5),K=0, 2)
40406 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
40408 IF(Q .LE. QMAVEC(IFL)) THEN
40413 IF(X .GE. 1.D0) THEN
40418 TMP = LOG(Q/ALFVEC(IFL))
40419 IF(TMP .LE. 0.D0) THEN
40431 DO 100 K = 0, MLFVEC(IFL)
40432 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40438 U = LOG(X/0.00001D0)
40440 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40441 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40442 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40443 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40444 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40446 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40448 C...Include threshold factor.
40449 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
40454 C*********************************************************************
40457 C...Auxiliary function for parametrization of CTEQ5M1.
40458 C...Author: J. Pumplin 9/99.
40460 FUNCTION PYCT5M(IFL,X,Q)
40462 C...Double precision declaration.
40463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40464 IMPLICIT INTEGER(I-N)
40466 PARAMETER (NEX=8, NLF=2)
40467 DIMENSION AM(0:NEX,0:NLF,-5:2)
40468 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40469 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40470 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40471 DIMENSION AF(0:NEX)
40473 DATA MEXVEC( 2) / 8 /
40474 DATA MLFVEC( 2) / 2 /
40475 DATA UT1VEC( 2) / 0.5141718E+01 /
40476 DATA UT2VEC( 2) / -0.1346944E+01 /
40477 DATA ALFVEC( 2) / 0.5260555E+00 /
40478 DATA QMAVEC( 2) / 0.0000000E+00 /
40479 DATA (AM( 0,K, 2),K=0, 2)
40480 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
40481 DATA (AM( 1,K, 2),K=0, 2)
40482 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
40483 DATA (AM( 2,K, 2),K=0, 2)
40484 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
40485 DATA (AM( 3,K, 2),K=0, 2)
40486 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
40487 DATA (AM( 4,K, 2),K=0, 2)
40488 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
40489 DATA (AM( 5,K, 2),K=0, 2)
40490 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
40491 DATA (AM( 6,K, 2),K=0, 2)
40492 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
40493 DATA (AM( 7,K, 2),K=0, 2)
40494 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
40495 DATA (AM( 8,K, 2),K=0, 2)
40496 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
40498 DATA MEXVEC( 1) / 8 /
40499 DATA MLFVEC( 1) / 2 /
40500 DATA UT1VEC( 1) / 0.4138426E+01 /
40501 DATA UT2VEC( 1) / -0.3221374E+01 /
40502 DATA ALFVEC( 1) / 0.4960962E+00 /
40503 DATA QMAVEC( 1) / 0.0000000E+00 /
40504 DATA (AM( 0,K, 1),K=0, 2)
40505 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
40506 DATA (AM( 1,K, 1),K=0, 2)
40507 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
40508 DATA (AM( 2,K, 1),K=0, 2)
40509 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
40510 DATA (AM( 3,K, 1),K=0, 2)
40511 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
40512 DATA (AM( 4,K, 1),K=0, 2)
40513 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
40514 DATA (AM( 5,K, 1),K=0, 2)
40515 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
40516 DATA (AM( 6,K, 1),K=0, 2)
40517 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
40518 DATA (AM( 7,K, 1),K=0, 2)
40519 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
40520 DATA (AM( 8,K, 1),K=0, 2)
40521 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
40523 DATA MEXVEC( 0) / 8 /
40524 DATA MLFVEC( 0) / 2 /
40525 DATA UT1VEC( 0) / -0.1026789E+01 /
40526 DATA UT2VEC( 0) / -0.9051707E+01 /
40527 DATA ALFVEC( 0) / 0.9462977E+00 /
40528 DATA QMAVEC( 0) / 0.0000000E+00 /
40529 DATA (AM( 0,K, 0),K=0, 2)
40530 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
40531 DATA (AM( 1,K, 0),K=0, 2)
40532 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
40533 DATA (AM( 2,K, 0),K=0, 2)
40534 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
40535 DATA (AM( 3,K, 0),K=0, 2)
40536 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
40537 DATA (AM( 4,K, 0),K=0, 2)
40538 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
40539 DATA (AM( 5,K, 0),K=0, 2)
40540 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
40541 DATA (AM( 6,K, 0),K=0, 2)
40542 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
40543 DATA (AM( 7,K, 0),K=0, 2)
40544 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
40545 DATA (AM( 8,K, 0),K=0, 2)
40546 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
40548 DATA MEXVEC(-1) / 8 /
40549 DATA MLFVEC(-1) / 2 /
40550 DATA UT1VEC(-1) / 0.5243571E+01 /
40551 DATA UT2VEC(-1) / -0.2870513E+01 /
40552 DATA ALFVEC(-1) / 0.6701448E+00 /
40553 DATA QMAVEC(-1) / 0.0000000E+00 /
40554 DATA (AM( 0,K,-1),K=0, 2)
40555 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
40556 DATA (AM( 1,K,-1),K=0, 2)
40557 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
40558 DATA (AM( 2,K,-1),K=0, 2)
40559 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
40560 DATA (AM( 3,K,-1),K=0, 2)
40561 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
40562 DATA (AM( 4,K,-1),K=0, 2)
40563 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
40564 DATA (AM( 5,K,-1),K=0, 2)
40565 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
40566 DATA (AM( 6,K,-1),K=0, 2)
40567 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
40568 DATA (AM( 7,K,-1),K=0, 2)
40569 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
40570 DATA (AM( 8,K,-1),K=0, 2)
40571 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
40573 DATA MEXVEC(-2) / 7 /
40574 DATA MLFVEC(-2) / 2 /
40575 DATA UT1VEC(-2) / 0.4782210E+01 /
40576 DATA UT2VEC(-2) / -0.1976856E+02 /
40577 DATA ALFVEC(-2) / 0.7558374E+00 /
40578 DATA QMAVEC(-2) / 0.0000000E+00 /
40579 DATA (AM( 0,K,-2),K=0, 2)
40580 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
40581 DATA (AM( 1,K,-2),K=0, 2)
40582 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
40583 DATA (AM( 2,K,-2),K=0, 2)
40584 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
40585 DATA (AM( 3,K,-2),K=0, 2)
40586 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
40587 DATA (AM( 4,K,-2),K=0, 2)
40588 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
40589 DATA (AM( 5,K,-2),K=0, 2)
40590 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
40591 DATA (AM( 6,K,-2),K=0, 2)
40592 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
40593 DATA (AM( 7,K,-2),K=0, 2)
40594 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
40596 DATA MEXVEC(-3) / 7 /
40597 DATA MLFVEC(-3) / 2 /
40598 DATA UT1VEC(-3) / 0.4518239E+01 /
40599 DATA UT2VEC(-3) / -0.2690590E+01 /
40600 DATA ALFVEC(-3) / 0.6124079E+00 /
40601 DATA QMAVEC(-3) / 0.0000000E+00 /
40602 DATA (AM( 0,K,-3),K=0, 2)
40603 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
40604 DATA (AM( 1,K,-3),K=0, 2)
40605 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
40606 DATA (AM( 2,K,-3),K=0, 2)
40607 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
40608 DATA (AM( 3,K,-3),K=0, 2)
40609 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
40610 DATA (AM( 4,K,-3),K=0, 2)
40611 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
40612 DATA (AM( 5,K,-3),K=0, 2)
40613 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
40614 DATA (AM( 6,K,-3),K=0, 2)
40615 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
40616 DATA (AM( 7,K,-3),K=0, 2)
40617 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
40619 DATA MEXVEC(-4) / 7 /
40620 DATA MLFVEC(-4) / 2 /
40621 DATA UT1VEC(-4) / 0.2783230E+01 /
40622 DATA UT2VEC(-4) / -0.1746328E+01 /
40623 DATA ALFVEC(-4) / 0.1115653E+01 /
40624 DATA QMAVEC(-4) / 0.1300000E+01 /
40625 DATA (AM( 0,K,-4),K=0, 2)
40626 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
40627 DATA (AM( 1,K,-4),K=0, 2)
40628 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
40629 DATA (AM( 2,K,-4),K=0, 2)
40630 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
40631 DATA (AM( 3,K,-4),K=0, 2)
40632 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
40633 DATA (AM( 4,K,-4),K=0, 2)
40634 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
40635 DATA (AM( 5,K,-4),K=0, 2)
40636 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
40637 DATA (AM( 6,K,-4),K=0, 2)
40638 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
40639 DATA (AM( 7,K,-4),K=0, 2)
40640 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
40642 DATA MEXVEC(-5) / 6 /
40643 DATA MLFVEC(-5) / 2 /
40644 DATA UT1VEC(-5) / 0.1619654E+02 /
40645 DATA UT2VEC(-5) / -0.3367346E+01 /
40646 DATA ALFVEC(-5) / 0.5109891E-02 /
40647 DATA QMAVEC(-5) / 0.4500000E+01 /
40648 DATA (AM( 0,K,-5),K=0, 2)
40649 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
40650 DATA (AM( 1,K,-5),K=0, 2)
40651 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
40652 DATA (AM( 2,K,-5),K=0, 2)
40653 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
40654 DATA (AM( 3,K,-5),K=0, 2)
40655 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
40656 DATA (AM( 4,K,-5),K=0, 2)
40657 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
40658 DATA (AM( 5,K,-5),K=0, 2)
40659 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
40660 DATA (AM( 6,K,-5),K=0, 2)
40661 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
40663 IF(Q .LE. QMAVEC(IFL)) THEN
40668 IF(X .GE. 1.D0) THEN
40673 TMP = LOG(Q/ALFVEC(IFL))
40674 IF(TMP .LE. 0.D0) THEN
40686 DO 100 K = 0, MLFVEC(IFL)
40687 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40693 U = LOG(X/0.00001D0)
40695 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40696 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40697 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40698 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40699 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40701 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40703 C...Include threshold factor.
40704 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
40709 C*********************************************************************
40712 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
40713 C...a few older parametrizations, now obsolete but convenient for
40714 C...backwards checks.
40716 SUBROUTINE PYPDPO(X,Q2,XPPR)
40718 C...Double precision and integer declarations.
40719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40720 IMPLICIT INTEGER(I-N)
40721 INTEGER PYK,PYCHGE,PYCOMP
40723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40725 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40726 COMMON/PYINT1/MINT(400),VINT(400)
40727 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40728 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
40729 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
40732 C...The following data lines are coefficients needed in the
40733 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
40734 C...parametrizations, see below.
40735 C...Powers of 1-x in different cases.
40736 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
40737 C...Expansion coefficients for up valence quark distribution.
40738 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
40739 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
40740 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
40741 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
40742 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
40743 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
40744 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
40745 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
40746 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
40747 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
40748 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
40749 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
40750 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
40751 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
40752 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
40753 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
40754 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
40755 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
40756 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
40757 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
40758 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
40759 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
40760 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
40761 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
40762 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
40763 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
40764 C...Expansion coefficients for down valence quark distribution.
40765 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
40766 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
40767 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
40768 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
40769 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
40770 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
40771 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
40772 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
40773 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
40774 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
40775 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
40776 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
40777 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
40778 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
40779 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
40780 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
40781 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
40782 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
40783 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
40784 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
40785 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
40786 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
40787 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
40788 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
40789 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
40790 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
40791 C...Expansion coefficients for up and down sea quark distributions.
40792 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
40793 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
40794 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
40795 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
40796 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
40797 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
40798 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
40799 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
40800 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
40801 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
40802 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
40803 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
40804 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
40805 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
40806 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
40807 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
40808 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
40809 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
40810 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
40811 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
40812 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
40813 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
40814 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
40815 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
40816 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
40817 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
40818 C...Expansion coefficients for gluon distribution.
40819 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
40820 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
40821 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
40822 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
40823 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
40824 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
40825 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
40826 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
40827 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
40828 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
40829 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
40830 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
40831 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
40832 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
40833 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
40834 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
40835 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
40836 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
40837 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
40838 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
40839 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
40840 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
40841 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
40842 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
40843 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
40844 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
40845 C...Expansion coefficients for strange sea quark distribution.
40846 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
40847 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
40848 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
40849 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
40850 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
40851 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
40852 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
40853 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
40854 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
40855 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
40856 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
40857 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
40858 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
40859 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
40860 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
40861 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
40862 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
40863 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
40864 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
40865 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
40866 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
40867 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
40868 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
40869 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
40870 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
40871 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
40872 C...Expansion coefficients for charm sea quark distribution.
40873 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
40874 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
40875 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
40876 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
40877 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
40878 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
40879 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
40880 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
40881 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
40882 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
40883 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
40884 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
40885 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
40886 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
40887 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
40888 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
40889 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
40890 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
40891 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
40892 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
40893 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
40894 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
40895 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
40896 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
40897 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
40898 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
40899 C...Expansion coefficients for bottom sea quark distribution.
40900 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
40901 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
40902 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
40903 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
40904 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
40905 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
40906 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
40907 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
40908 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
40909 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
40910 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40911 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40912 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40913 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40914 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40915 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40916 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40917 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40918 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40919 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40920 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40921 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40922 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40923 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40924 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40925 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40926 C...Expansion coefficients for top sea quark distribution.
40927 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40928 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40929 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40930 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40931 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40932 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40933 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40934 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40935 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40936 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40937 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40938 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40939 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40940 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40941 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40942 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40943 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40944 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40945 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40946 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40947 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40948 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40949 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40950 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40951 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40952 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40954 C...The following data lines are coefficients needed in the
40955 C...Duke, Owens proton structure function parametrizations, see below.
40956 C...Expansion coefficients for (up+down) valence quark distribution.
40957 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40958 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40959 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40960 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40961 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40962 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40963 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40964 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40965 C...Expansion coefficients for down valence quark distribution.
40966 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40967 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40968 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40969 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40970 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40971 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40972 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40973 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40974 C...Expansion coefficients for (up+down+strange) sea quark distribution.
40975 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40976 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40977 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40978 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
40979 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
40980 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40981 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
40982 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
40983 C...Expansion coefficients for charm sea quark distribution.
40984 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
40985 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40986 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
40987 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
40988 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
40989 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40990 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
40991 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
40992 C...Expansion coefficients for gluon distribution.
40993 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
40994 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40995 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
40996 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
40997 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
40998 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40999 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41000 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41002 C...Euler's beta function, requires ordinary Gamma function
41003 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41005 C...Leading order proton parton distributions from Glueck, Reya and
41006 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41008 IF(MSTP(51).EQ.11) THEN
41010 C...Determine s expansion variable and some x expressions.
41011 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41012 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41017 C...Evaluate valence, gluon and sea distributions.
41018 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41019 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41020 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41021 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41022 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41023 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41024 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41025 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41026 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41027 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41028 & SQRT(4.066D0*SD**1.218D0*XL)))*
41029 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41030 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41031 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41032 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41033 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41034 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41035 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41036 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41037 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41038 IF(SD.LE.0.888D0) THEN
41041 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41042 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41043 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41045 IF(SD.LE.1.351D0) THEN
41048 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41049 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41050 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41053 C...Put into output array.
41055 XPPR(1)=XFVDD+XFSEA
41056 XPPR(2)=XFVUD-XFVDD+XFSEA
41066 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41067 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41068 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41070 C...Determine set, Lambda and x and t expansion variables.
41072 IF(NSET.EQ.1) ALAM=0.2D0
41073 IF(NSET.EQ.2) ALAM=0.29D0
41074 TMIN=LOG(5D0/ALAM**2)
41075 TMAX=LOG(1D8/ALAM**2)
41076 T=LOG(MAX(1D0,Q2/ALAM**2))
41077 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41079 IF(X.LE.0.1D0) NX=2
41080 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
41081 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
41083 C...Chebyshev polynomials for x and t expansion.
41086 TX(3)=2D0*VX**2-1D0
41087 TX(4)=4D0*VX**3-3D0*VX
41088 TX(5)=8D0*VX**4-8D0*VX**2+1D0
41089 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
41092 TT(3)=2D0*VT**2-1D0
41093 TT(4)=4D0*VT**3-3D0*VT
41094 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41095 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41097 C...Calculate structure functions.
41102 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
41105 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
41108 C...Put into output array.
41110 XPPR(1)=XQ(2)+XQ(3)
41111 XPPR(2)=XQ(1)+XQ(3)
41119 C...Special expansion for bottom (threshold effects).
41120 IF(MSTP(58).GE.5) THEN
41121 IF(NSET.EQ.1) TMIN=8.1905D0
41122 IF(NSET.EQ.2) TMIN=7.4474D0
41124 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41127 TT(3)=2D0*VT**2-1D0
41128 TT(4)=4D0*VT**3-3D0*VT
41129 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41130 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41134 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
41137 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
41142 C...Special expansion for top (threshold effects).
41143 IF(MSTP(58).GE.6) THEN
41144 IF(NSET.EQ.1) TMIN=11.5528D0
41145 IF(NSET.EQ.2) TMIN=10.8097D0
41146 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
41147 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
41149 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41152 TT(3)=2D0*VT**2-1D0
41153 TT(4)=4D0*VT**3-3D0*VT
41154 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41155 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41159 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
41162 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
41167 C...Proton parton distributions from Duke, Owens.
41168 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
41169 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
41171 C...Determine set, Lambda and s expansion parameter.
41173 IF(NSET.EQ.1) ALAM=0.2D0
41174 IF(NSET.EQ.2) ALAM=0.4D0
41175 Q2IN=MIN(1D6,MAX(4D0,Q2))
41176 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
41178 C...Calculate structure functions.
41181 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
41182 & CDO(3,IS,KFL,NSET)*SD**2
41185 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
41186 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
41188 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
41189 & TS(5)*X**2+TS(6)*X**3)
41193 C...Put into output arrays.
41195 XPPR(1)=XQ(2)+XQ(3)/6D0
41196 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
41209 C*********************************************************************
41212 C...Gives threshold attractive/repulsive factor for heavy flavour
41215 FUNCTION PYHFTH(SH,SQM,FRATT)
41217 C...Double precision and integer declarations.
41218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41219 IMPLICIT INTEGER(I-N)
41220 INTEGER PYK,PYCHGE,PYCOMP
41222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41223 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41224 COMMON/PYINT1/MINT(400),VINT(400)
41225 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
41227 C...Value for alpha_strong.
41228 IF(MSTP(35).LE.1) THEN
41233 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
41239 C...Evaluate attractive and repulsive factors.
41240 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41241 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
41242 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41243 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
41244 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
41250 C*********************************************************************
41253 C...Splits a hadron remnant into two (partons or hadron + parton)
41254 C...in case it is more complicated than just a quark or a diquark.
41256 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
41258 C...Double precision and integer declarations.
41259 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41260 IMPLICIT INTEGER(I-N)
41261 INTEGER PYK,PYCHGE,PYCOMP
41262 C...Commonblocks. PYDAT1 temporary
41263 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41264 COMMON/PYINT1/MINT(400),VINT(400)
41265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41266 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
41270 C...Preliminaries. Parton composition.
41273 KFL(1)=MOD(KFA/1000,10)
41274 KFL(2)=MOD(KFA/100,10)
41275 KFL(3)=MOD(KFA/10,10)
41276 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
41277 KFL(2)=INT(1.5D0+PYR(0))
41278 IF(MINT(105).EQ.333) KFL(2)=3
41279 IF(MINT(105).EQ.443) KFL(2)=4
41281 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
41284 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
41287 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
41288 KFL(2)=MOD(KFA/10,10)
41289 KFL(3)=MOD(KFA/100,10)
41291 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
41298 C...Subdivide lepton.
41299 IF(KFA.GE.11.AND.KFA.LE.18) THEN
41300 IF(KFLR.EQ.KFA) THEN
41302 ELSEIF(KFLR.EQ.22) THEN
41304 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
41306 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
41308 ELSEIF(KFLR.EQ.21) THEN
41316 C...Subdivide photon.
41317 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
41318 IF(KFLR.NE.21) THEN
41323 IF(RAGR.GT.0.125D0) KFLSP=2
41324 IF(RAGR.GT.0.625D0) KFLSP=3
41325 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
41329 C...Subdivide Reggeon or Pomeron.
41330 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
41331 IF(KFLIN.EQ.21) THEN
41337 C...Subdivide meson.
41338 ELSEIF(KFL(1).EQ.0) THEN
41339 KFL(2)=KFL(2)*(-1)**KFL(2)
41340 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
41341 IF(KFLR.EQ.KFL(2)) THEN
41343 ELSEIF(KFLR.EQ.KFL(3)) THEN
41345 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
41348 ELSEIF(KFLR.EQ.21) THEN
41351 ELSEIF(KFLR*KFL(2).GT.0) THEN
41354 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
41355 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41357 ELSEIF(KFLCH.EQ.0) THEN
41358 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41366 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
41367 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41369 ELSEIF(KFLCH.EQ.0) THEN
41370 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41377 C...Special case for extracting photon from baryon without splitting
41378 C...the latter. (Currently only used by external programs.)
41379 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
41383 C...Subdivide baryon.
41387 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
41390 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
41393 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
41394 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
41397 IAGR=1.00001D0+2.99998D0*PYR(0)
41400 IF(IAGR.EQ.1) ID1=2
41401 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
41404 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
41405 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
41406 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
41407 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
41408 ELSEIF(MOD(KFA,10).EQ.2) THEN
41409 IF(IAGR.EQ.1) KSP=1
41410 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
41412 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
41413 IF(KFLR.EQ.21) THEN
41415 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
41418 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
41419 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41421 ELSEIF(KFLCH.EQ.0) THEN
41422 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41426 ELSEIF(NAGR.EQ.0) THEN
41429 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
41430 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41432 ELSEIF(KFLCH.EQ.0) THEN
41433 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41441 C...Add on correct sign for result.
41448 C*********************************************************************
41451 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
41452 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
41453 C...(Dover, 1965) 6.1.36.
41457 C...Double precision and integer declarations.
41458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41459 IMPLICIT INTEGER(I-N)
41460 INTEGER PYK,PYCHGE,PYCOMP
41461 C...Local array and data.
41463 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
41464 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
41473 PYGAMM=PYGAMM+B(I)*DXP
41479 PYGAMM=(X-IX)*PYGAMM
41486 C***********************************************************************
41489 C...Calculates real and imaginary parts of the auxiliary functions W1
41490 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
41491 C...der Bij, Nucl. Phys. B297 (1988) 221.
41493 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
41495 C...Double precision and integer declarations.
41496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41497 IMPLICIT INTEGER(I-N)
41498 INTEGER PYK,PYCHGE,PYCOMP
41500 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41503 ASINH(X)=LOG(X+SQRT(X**2+1D0))
41504 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
41506 IF(EPS.LT.0D0) THEN
41507 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
41508 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
41510 ELSEIF(EPS.LT.1D0) THEN
41511 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
41512 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
41513 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
41514 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
41516 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
41517 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
41524 C***********************************************************************
41527 C...Calculates real and imaginary parts of the auxiliary function I3;
41528 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
41529 C...Nucl. Phys. B297 (1988) 221.
41531 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
41533 C...Double precision and integer declarations.
41534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41535 IMPLICIT INTEGER(I-N)
41536 INTEGER PYK,PYCHGE,PYCOMP
41538 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41541 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
41542 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
41544 IF(EPS.LT.0D0) THEN
41545 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41546 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41547 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41548 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
41549 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
41550 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
41551 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
41552 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
41554 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41555 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41556 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41557 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
41558 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
41559 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
41560 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
41561 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
41562 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41563 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41564 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41565 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
41566 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
41567 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
41568 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
41569 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
41571 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41572 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
41573 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
41574 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
41575 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
41578 ELSEIF(EPS.LT.1D0) THEN
41579 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41580 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41581 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41582 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
41583 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
41584 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41585 & (0.25D0*(RAT+1D0)*EPS))
41586 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41587 & (0.25D0*(RAT+1D0)*EPS))
41588 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41589 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41590 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41591 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
41592 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
41593 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
41594 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41595 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41596 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41597 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41598 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41599 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
41600 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
41601 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
41602 & (1D0+0.25D0*RAT*EPS-GA))
41603 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
41604 & (1D0+0.25D0*RAT*EPS-GA))
41606 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41607 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
41608 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
41609 & LOG((GA+BE-1D0)/(BE-GA))
41610 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
41613 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
41614 RCTHE=RSQ*(1D0-2D0*BE/EPS)
41615 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
41616 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
41617 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
41619 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
41620 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
41621 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
41622 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
41623 & (PHI-THE)*(PHI+THE-PARU(1))
41624 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
41625 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
41628 Y3RE=2D0/(2D0*BE-1D0)*F3RE
41629 Y3IM=2D0/(2D0*BE-1D0)*F3IM
41634 C***********************************************************************
41637 C...Calculates real and imaginary part of Spence function; see
41638 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
41640 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
41642 C...Double precision and integer declarations.
41643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41644 IMPLICIT INTEGER(I-N)
41645 INTEGER PYK,PYCHGE,PYCOMP
41647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41649 C...Local array and data.
41652 &1.000000D+00, -5.000000D-01, 1.666667D-01,
41653 &0.000000D+00, -3.333333D-02, 0.000000D+00,
41654 &2.380952D-02, 0.000000D+00, -3.333333D-02,
41655 &0.000000D+00, 7.575757D-02, 0.000000D+00,
41656 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
41660 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
41661 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
41662 IF(IREIM.EQ.2) PYSPEN=0D0
41666 XMOD=SQRT(XRE**2+XIM**2)
41667 IF(XMOD.LT.1D-6) THEN
41668 IF(IREIM.EQ.1) PYSPEN=0D0
41669 IF(IREIM.EQ.2) PYSPEN=0D0
41673 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41677 IF(XMOD.GT.1D0) THEN
41679 ALGXIM=XARG-SIGN(PARU(1),XARG)
41680 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
41681 SP0IM=-ALGXRE*ALGXIM
41688 IF(XRE.GT.0.5D0) THEN
41693 XMOD=SQRT(XRE**2+XIM**2)
41694 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41697 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
41698 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
41704 XMOD=SQRT(XRE**2+XIM**2)
41705 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41714 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
41715 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
41716 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
41719 SPRE=SPRE+B(I)*TERMRE
41720 SPIM=SPIM+B(I)*TERMIM
41723 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
41724 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
41729 C***********************************************************************
41732 C...Calculates the matrix element for the processes
41733 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
41734 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
41735 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
41737 SUBROUTINE PYQQBH(WTQQBH)
41739 C...Double precision and integer declarations.
41740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41741 IMPLICIT INTEGER(I-N)
41742 INTEGER PYK,PYCHGE,PYCOMP
41744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41747 COMMON/PYINT1/MINT(400),VINT(400)
41748 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41749 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
41750 C...Local arrays and function.
41751 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
41752 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
41755 C...Mass parameters.
41758 SHPR=SQRT(VINT(26))*VINT(1)
41759 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
41760 PH=SQRT(VINT(21))*VINT(1)
41764 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
41766 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41767 PP(I,1)=PT*COS(VINT(198+5*I))
41768 PP(I,2)=PT*SIN(VINT(198+5*I))
41770 PP(3,1)=-PP(1,1)-PP(2,1)
41771 PP(3,2)=-PP(1,2)-PP(2,2)
41772 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
41773 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
41774 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
41776 PP(3,3)=PMT3*SINH(VINT(211))
41777 PP(3,4)=PMT3*COSH(VINT(211))
41778 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
41779 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41780 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
41781 PP(2,3)=-PP(1,3)-PP(3,3)
41782 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
41783 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
41785 C...Set up incoming kinematics and derived momentum combinations.
41789 PP(I,3)=-0.5D0*SHPR*(-1)**I
41790 PP(I,4)=-0.5D0*SHPR
41793 PP(6,J)=PP(1,J)+PP(2,J)
41794 PP(7,J)=PP(1,J)+PP(3,J)
41795 PP(8,J)=PP(1,J)+PP(4,J)
41796 PP(9,J)=PP(1,J)+PP(5,J)
41797 PP(10,J)=-PP(2,J)-PP(3,J)
41798 PP(11,J)=-PP(2,J)-PP(4,J)
41799 PP(12,J)=-PP(2,J)-PP(5,J)
41800 PP(13,J)=-PP(4,J)-PP(5,J)
41803 C...Derived kinematics invariants.
41832 C...Define colour coefficients for g + g -> Q + Qbar + H.
41833 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
41837 CLR(I+3,J+3)=16D0/3D0
41838 CLR(I,J+3)=-2D0/3D0
41839 CLR(I+3,J)=-2D0/3D0
41852 CLR(6+K1,6+K2)=12D0
41856 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
41857 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
41858 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
41859 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
41860 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
41861 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
41862 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
41864 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
41865 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
41866 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41867 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
41868 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
41869 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
41870 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
41871 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
41872 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
41873 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
41874 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
41875 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
41876 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41877 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
41878 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
41879 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
41880 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
41881 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
41883 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
41884 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
41885 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
41886 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
41887 & +X4*X9*X5+X4*X5**2)
41888 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
41889 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
41890 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
41891 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
41892 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
41893 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
41894 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
41895 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
41896 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
41897 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
41898 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
41899 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
41900 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
41901 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
41902 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
41903 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
41904 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
41905 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
41906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
41907 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
41909 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
41910 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41911 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
41912 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
41913 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
41914 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
41915 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41917 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41918 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41919 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41920 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41921 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41922 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41924 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41925 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41926 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41927 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41928 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41929 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41930 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41932 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41933 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41934 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41935 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41936 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41937 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41938 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41939 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41940 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41941 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41942 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41943 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41944 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41945 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41946 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41947 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41948 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41949 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41950 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41951 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41952 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41953 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41954 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41955 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41956 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41957 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41958 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41959 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41960 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41961 & +X3*X8*X5+X3*X5**2)
41962 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41963 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41964 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41965 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41966 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41967 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41968 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41970 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41971 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41972 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41973 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41974 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41975 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41976 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41977 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41978 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
41979 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
41980 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
41981 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
41982 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
41983 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
41984 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
41985 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
41986 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
41987 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
41988 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
41989 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
41990 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
41991 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
41992 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
41993 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
41994 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
41995 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
41997 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
41998 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
41999 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42000 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42001 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42002 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42003 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42004 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42005 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42006 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42007 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42008 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42009 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42010 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42011 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42012 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42013 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42014 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42015 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42016 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42017 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42018 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42019 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42020 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42021 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42022 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42024 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42025 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42026 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42027 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42028 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42029 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42030 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42031 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42032 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42033 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42034 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42035 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42036 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42037 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42038 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42039 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42040 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42041 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42042 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42043 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42044 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42045 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42046 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42047 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42048 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42049 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42050 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42051 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42052 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42053 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42054 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42055 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42056 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42057 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42058 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42059 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42060 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42061 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42062 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42063 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42064 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42065 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42066 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42067 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42069 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42070 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42071 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42072 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42073 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42074 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42075 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
42076 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
42077 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
42078 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
42079 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
42081 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42082 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
42083 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
42084 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42085 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
42086 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
42088 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42089 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
42090 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
42092 FM(9,10)=0.5D0*(FMXX+FM(9,10))
42093 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42094 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
42095 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
42097 C...Repackage matrix elements.
42103 RM(7,7)=FM(7,7)-2D0*FM(9,9)
42104 RM(7,8)=FM(7,8)-2D0*FM(9,10)
42105 RM(8,8)=FM(8,8)-2D0*FM(10,10)
42107 C...Produce final result: matrix elements * colours * propagators.
42112 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
42115 WTQQBH=-WTQQBH/256D0
42118 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42119 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
42120 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
42122 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
42123 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
42124 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
42126 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
42127 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
42130 C...Produce final result: matrix elements * propagators.
42132 A12=A12/(DX(7)*DX(8))
42134 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
42140 C*********************************************************************
42142 C...PYSTBH (and auxiliaries)
42143 C.. Evaluates the matrix elements for t + b + H production.
42145 SUBROUTINE PYSTBH(WTTBH)
42147 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42148 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42149 IMPLICIT INTEGER(I-N)
42150 INTEGER PYK,PYCHGE,PYCOMP
42153 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42154 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42155 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42156 COMMON/PYINT1/MINT(400),VINT(400)
42157 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42158 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
42159 COMMON/PYINT4/MWID(500),WIDS(500,5)
42160 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
42161 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42162 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
42163 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
42164 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
42165 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
42166 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42167 DOUBLE PRECISION MW2
42168 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
42169 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
42171 C...LOCAL ARRAYS AND COMPLEX VARIABLES
42172 DIMENSION QQ(4,2),PP(4,3)
42177 C...KINEMATIC PARAMETERS.
42178 SHPR=SQRT(VINT(26))*VINT(1)
42179 PH=SQRT(VINT(21))*VINT(1)
42182 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
42184 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42185 PP(1,I)=PT*COS(VINT(198+5*I))
42186 PP(2,I)=PT*SIN(VINT(198+5*I))
42188 PP(1,3)=-PP(1,1)-PP(1,2)
42189 PP(2,3)=-PP(2,1)-PP(2,2)
42190 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
42191 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
42192 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
42194 PP(3,3)=PMT3*SINH(VINT(211))
42195 PP(4,3)=PMT3*COSH(VINT(211))
42196 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
42197 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42198 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
42199 PP(3,2)=-PP(3,1)-PP(3,3)
42200 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
42201 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
42203 C...CM SYSTEM, INGOING QUARKS/GLUONS
42204 QQ(3,1) = SHPR/2.D0
42209 C...PARAMETERS FOR AMPLITUDE METHOD
42213 MW2 = PMAS(24,1)**2
42216 RMB=PYMRUN(5,VINT(52))
42220 IF (ISUB.EQ.401) THEN
42221 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42222 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42223 ELSE IF (ISUB.EQ.402) THEN
42224 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42225 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42230 C------------------------------------------------------------------
42231 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
42232 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
42233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42234 IMPLICIT INTEGER(I-N)
42235 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
42236 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42239 C TOP WIDTH CALCULATION
42246 IF (MT .LT. (MHP+MB)) THEN
42248 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42249 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42250 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42253 C T ->BW +T ->B H^+
42254 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42255 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42256 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42258 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
42259 & -4.D0*(MHP*MB/MT**2)**2 )
42260 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
42261 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
42262 GAMT = GAMTBW+GAMTBH
42269 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
42270 C GG->TBH^+, QQBAR->TBH^+
42271 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
42272 C (FOR INSTANCE WITH PYTHIA)
42273 C------------------------------------------------------------
42274 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
42275 C PHYS REV. D 60 (1999) 115011
42276 C (THESE FILES PREPARED BY J.-L. KNEUR)
42277 C------------------------------------------------------------
42279 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42281 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
42283 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
42284 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
42285 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
42286 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
42287 C "PHYSICAL PARAMETERS" INPUT:
42288 C MT,MB TOP AND BOTTOM MASSES;
42289 C MHP CHARGED HIGGS MASS
42290 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
42292 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
42293 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
42294 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
42295 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
42296 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
42297 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
42298 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
42300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42301 IMPLICIT INTEGER(I-N)
42302 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42303 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42306 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42308 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42309 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42310 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42311 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42312 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42313 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
42314 C (TAN BETA) VALUES
42316 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42317 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42322 C COLLECTING THE RELEVANT OVERALL FACTORS:
42323 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
42324 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
42325 C COUPLING CONSTANT (OVERALL NORMALIZATION)
42326 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42327 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42328 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42329 C ALPHAS IS ALPHA_STRONG;
42330 C SW2 IS SIN(THETA_W)**2.
42333 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42335 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42336 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42337 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42339 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42340 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42342 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42344 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42345 S = 2*PYTBHS(Q1,Q2)
42352 C TOP WIDTH CALCULATION
42353 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42354 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42355 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42356 A1INV= S -2*P1Q1 -2*P1Q2
42357 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42358 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42359 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
42361 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42362 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42363 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42364 C NOW COMES THE AMP**2:
42365 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
42366 C THE EXPRESSIONS BELOW
42369 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
42370 &512*A1*A2*MB*MT/3-
42371 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42372 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
42373 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
42374 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42375 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
42376 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
42377 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
42378 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
42379 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42380 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42381 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
42382 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
42383 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42384 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42385 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
42386 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
42387 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
42388 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
42389 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42390 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
42391 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
42392 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42393 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42394 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42395 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
42396 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42397 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42398 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42399 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42400 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42401 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
42402 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42403 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42404 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
42405 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
42406 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42407 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
42408 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42409 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42410 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
42411 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
42412 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42413 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
42414 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42415 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42416 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42417 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42418 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
42419 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
42420 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42421 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
42422 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42423 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42424 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42425 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42426 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42427 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
42428 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
42429 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
42430 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42431 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42432 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42433 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42434 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42435 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
42436 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42437 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42438 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42439 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
42440 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42441 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
42442 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42443 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42444 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
42445 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42446 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42447 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42448 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
42449 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42450 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42451 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42452 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42453 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42454 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42455 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
42456 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42457 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42458 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
42459 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42460 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42461 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42462 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42463 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42464 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42465 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
42466 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42467 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42468 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42469 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
42470 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42471 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42472 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42473 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42474 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42475 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
42476 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42477 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
42478 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42479 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
42480 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
42481 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42482 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42483 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42484 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42485 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
42486 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42487 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42488 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42489 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42490 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42491 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
42492 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42493 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42494 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42495 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42496 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42497 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
42498 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
42499 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42500 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42501 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42502 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
42503 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42504 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42505 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42506 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42507 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42508 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
42509 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42510 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
42511 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42512 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42513 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
42514 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42515 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42516 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42517 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42518 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42519 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
42520 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42521 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42522 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42523 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42524 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42525 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42526 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42527 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
42528 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42529 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42530 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42531 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42532 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42533 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
42534 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42535 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42536 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42537 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42538 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42539 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42540 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
42541 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42542 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
42543 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42544 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42545 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42546 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42547 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42548 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42549 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42550 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42551 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
42552 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42553 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42554 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
42555 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42556 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42557 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42558 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42559 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42560 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
42561 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42562 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42563 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42564 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
42565 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42566 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42567 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
42568 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42569 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42570 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42571 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42572 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42573 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42574 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42575 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42576 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42577 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42578 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42579 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42580 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42581 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42582 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42583 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42584 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42585 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42586 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42587 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
42588 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42589 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42590 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42591 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42592 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42593 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42594 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42595 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42596 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
42597 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42598 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42599 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42600 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42601 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42602 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42603 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42604 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42605 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
42606 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42607 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42608 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42609 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42610 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42611 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
42612 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42613 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42614 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42615 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42616 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42617 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42618 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42619 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42620 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
42621 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42622 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42623 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42624 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42625 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42626 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42627 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42628 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42629 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42630 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42631 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42632 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42633 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42634 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42635 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42636 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42637 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
42638 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42639 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42640 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42641 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
42642 &384*A12*MB*MT*P1Q1**2/S**2+
42643 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42644 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
42645 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42646 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42647 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42648 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42649 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
42650 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42651 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42652 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42653 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42654 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42655 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42656 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42657 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42658 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
42659 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42660 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
42661 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
42662 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
42663 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
42664 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
42665 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42666 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
42667 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
42668 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
42669 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
42670 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
42671 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
42672 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42673 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
42674 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42675 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
42676 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
42677 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42678 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42679 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
42680 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
42681 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
42682 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
42683 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42684 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42685 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42686 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42687 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
42688 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42689 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
42690 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
42691 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
42692 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
42693 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
42694 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42695 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
42696 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42697 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42698 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42699 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42700 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42701 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42702 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42703 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42704 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42705 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42706 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
42707 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
42708 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
42709 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
42710 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
42711 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
42712 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42713 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42714 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42715 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
42716 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42717 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
42718 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42719 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42720 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42721 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42722 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42723 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42724 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
42725 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42726 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
42727 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42728 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
42729 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42730 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42731 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
42732 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
42733 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42734 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42735 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42736 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42737 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
42738 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42739 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
42740 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42741 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42742 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42743 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
42744 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42745 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
42746 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42747 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
42748 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
42749 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
42750 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42751 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
42752 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
42753 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42754 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42755 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42756 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42757 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42758 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42759 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42760 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42761 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42762 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
42763 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42764 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42765 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42766 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42767 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42768 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42769 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42770 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42771 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42772 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
42773 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42774 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
42775 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42776 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42777 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42778 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42779 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
42780 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
42781 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42782 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
42783 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
42784 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42785 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42786 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
42787 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42788 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42789 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
42790 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42791 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42792 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42793 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
42794 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
42795 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42796 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
42797 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
42798 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42799 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42800 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42801 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42802 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42803 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42804 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
42805 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
42806 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
42807 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42808 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42809 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42810 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42811 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42812 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
42813 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
42814 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42815 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42816 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42817 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
42818 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
42821 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42822 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42823 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42824 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42825 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42826 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42827 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42828 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42829 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42830 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42831 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
42832 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42833 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42834 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
42835 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42836 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
42837 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
42838 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
42839 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42840 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42841 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42842 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42843 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42844 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42845 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
42846 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
42847 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42848 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42849 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
42850 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
42851 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42852 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
42853 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
42854 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
42855 &272*A1*A2*P1Q1*S/(3*P1Q2)+
42856 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
42857 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42858 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
42859 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42860 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42861 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42862 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42863 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42864 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
42865 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42866 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42867 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
42868 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42869 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
42870 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
42871 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42872 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42873 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
42874 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
42875 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
42876 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42877 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
42878 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42879 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
42880 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42881 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42882 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
42883 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42884 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42885 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
42886 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42887 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
42888 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
42889 &32*A12*P2Q1*S/(3*P1Q1)-
42890 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42891 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
42892 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
42893 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42894 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42895 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42896 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42897 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42898 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
42899 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42900 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42901 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
42902 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42903 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42904 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
42905 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
42906 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
42907 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42908 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
42909 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42910 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42911 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
42912 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42913 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
42914 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42915 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
42916 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42917 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42918 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42919 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42920 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42921 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42922 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42923 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42924 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42925 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42926 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42927 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42928 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42929 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42930 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42931 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42932 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42933 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42934 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42935 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42936 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42937 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42938 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42939 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42940 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42941 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42942 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42943 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42944 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42945 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42946 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42947 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42948 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42949 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42950 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42951 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42952 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42953 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42954 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42955 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42956 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42957 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42958 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42959 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42960 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42961 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42962 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42963 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42966 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42967 &512*A1*A2*MB*MT/3+
42968 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42969 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42970 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42971 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42972 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42973 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42974 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42975 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42976 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42977 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42978 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
42979 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
42980 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42981 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42982 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
42983 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
42984 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
42985 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
42986 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42987 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
42988 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
42989 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42990 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42991 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42992 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
42993 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42994 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42995 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42996 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42997 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42998 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
42999 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43000 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43001 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43002 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43003 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43004 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43005 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43006 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43007 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43008 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43009 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43010 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43011 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43012 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43013 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43014 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43015 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43016 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43017 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43018 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43019 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43020 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43021 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43022 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43023 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43024 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43025 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43026 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43027 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43028 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43029 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43030 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43031 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43032 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43033 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43034 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43035 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43036 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43037 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43038 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43039 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43040 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43041 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43042 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43043 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43044 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43045 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43046 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43047 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43048 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43049 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43050 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43051 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43052 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43053 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43054 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43055 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43056 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43057 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43058 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43059 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43060 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43061 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43062 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43063 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43064 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43065 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43066 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43067 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43068 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43069 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43070 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43071 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43072 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43073 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43074 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43075 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43076 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
43077 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
43078 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43079 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43080 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43081 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43082 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
43083 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43084 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43085 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43086 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43087 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43088 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
43089 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43090 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43091 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43092 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43093 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43094 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
43095 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
43096 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43097 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43098 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43099 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
43100 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43101 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43102 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43103 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43104 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43105 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
43106 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43107 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
43108 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43109 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43110 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
43111 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43112 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43113 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43114 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43115 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43116 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43117 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43118 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43119 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43120 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43121 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
43122 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43123 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43124 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
43125 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43126 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43127 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
43128 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43129 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43130 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
43131 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43132 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43133 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
43134 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43135 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43136 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43137 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
43138 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43139 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
43140 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43141 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43142 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43143 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43144 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43145 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43146 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43147 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43148 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43149 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43150 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43151 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43152 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43153 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43154 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43155 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43156 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43157 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
43158 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43159 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43160 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43161 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
43162 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43163 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43164 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
43165 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43166 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43167 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43168 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43169 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43170 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43171 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43172 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43173 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43174 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43175 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43176 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43177 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43178 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
43179 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43180 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43181 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43182 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43183 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43184 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
43185 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43186 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43187 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43188 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43189 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43190 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43191 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43192 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43193 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
43194 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43195 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43196 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43197 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43198 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43199 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43200 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43201 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43202 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
43203 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43204 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43205 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43206 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43207 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43208 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
43209 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43210 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43211 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
43212 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43213 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43214 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43215 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43216 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43217 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
43218 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43219 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43220 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43221 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43222 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43223 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43224 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43225 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43226 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
43227 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43228 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43229 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43230 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43231 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43232 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43233 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43234 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
43235 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43236 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43237 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43238 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
43239 &384*A12*MB*MT*P1Q1**2/S**2+
43240 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43241 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
43242 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43243 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43244 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43245 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43246 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
43247 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43248 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43249 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43250 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43251 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43252 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43253 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43254 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
43255 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
43256 &384*A2**2*MB*MT*P2Q2**2/S**2+
43257 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43258 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
43259 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
43260 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
43261 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
43262 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
43263 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43264 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
43265 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
43266 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
43267 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
43268 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
43269 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
43270 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43271 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
43272 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43273 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
43274 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43275 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43276 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
43277 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
43278 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
43279 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
43280 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43281 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43282 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43283 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43284 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
43285 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43286 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
43287 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
43288 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
43289 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
43290 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
43291 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43292 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
43293 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43294 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
43295 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43296 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43297 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43298 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
43299 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43300 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43301 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43302 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43303 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
43304 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
43305 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
43306 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
43307 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
43308 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43309 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43310 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43311 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
43312 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43313 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
43314 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43315 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43316 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43317 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43318 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43319 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43320 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
43321 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43322 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
43323 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43324 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
43325 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43326 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43327 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
43328 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
43329 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43330 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43331 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43332 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43333 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
43334 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43335 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
43336 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43337 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
43338 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43339 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
43340 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43341 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
43342 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43343 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
43344 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
43345 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
43346 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43347 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
43348 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
43349 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43350 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43351 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43352 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43353 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
43354 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43355 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43356 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
43357 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
43358 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
43359 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43360 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43361 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43362 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43363 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43364 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43365 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43366 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43367 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43368 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
43369 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43370 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
43371 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43372 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43373 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
43374 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
43375 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43376 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
43377 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43378 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
43379 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
43380 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43381 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43382 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
43383 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43384 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43385 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
43386 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43387 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43388 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43389 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
43390 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
43391 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43392 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
43393 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43394 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43395 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43396 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43397 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43398 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43399 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
43400 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
43401 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
43402 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43403 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43404 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43405 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
43406 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43407 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
43408 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
43409 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43410 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43411 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43412 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43413 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43414 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43415 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43416 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43417 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43418 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43419 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43420 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
43421 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43422 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43423 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43424 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
43425 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43426 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43427 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
43428 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43429 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
43430 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
43431 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43432 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43433 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43434 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43435 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43436 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43437 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
43438 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
43439 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43440 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43441 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
43442 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
43443 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43444 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
43445 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
43446 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
43447 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
43448 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43449 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
43452 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43453 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43454 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43455 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43456 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43457 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
43458 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43459 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43460 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
43461 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43462 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
43463 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
43464 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43465 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43466 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
43467 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
43468 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
43470 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43471 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
43472 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43473 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
43474 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43475 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43476 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43477 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43478 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43479 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
43480 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43481 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
43482 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
43483 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43484 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
43485 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
43486 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
43487 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43488 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43489 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43490 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43491 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43492 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
43493 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43494 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43495 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
43496 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43497 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43498 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
43499 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
43500 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43501 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
43502 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43503 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43504 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
43505 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43506 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
43507 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43508 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
43509 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43510 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43511 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43512 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43513 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43514 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
43515 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
43516 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43517 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
43518 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
43519 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43520 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43521 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43522 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43523 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43524 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43525 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43526 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43527 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43528 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43529 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43530 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43531 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
43532 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
43533 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
43534 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43535 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
43536 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43537 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43538 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43539 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43540 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43541 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43542 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43543 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
43544 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43545 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43546 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43547 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
43548 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
43549 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43550 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43551 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
43552 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
43553 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43554 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43555 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43559 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
43560 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
43561 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43562 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43563 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43564 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
43565 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43566 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43567 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43568 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43569 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43570 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43571 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
43572 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
43573 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
43574 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
43575 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
43576 V910=V910+96*A1*A2*P1P2*P2Q1/S-
43577 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43578 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
43579 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
43580 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43581 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43583 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
43584 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
43585 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43586 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43587 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43588 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
43589 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43590 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43591 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
43592 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43593 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43594 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43595 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
43596 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
43597 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
43598 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
43599 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
43600 A910=A910+96*A1*A2*P1P2*P2Q1/S-
43601 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43602 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
43603 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
43604 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43605 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43609 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
43612 C---------------------------------------------------------
43613 C 2) Q QBAR ->TBH^+
43614 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43616 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
43617 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
43618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43619 IMPLICIT INTEGER(I-N)
43620 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43621 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43623 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43624 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43625 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43626 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43627 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43628 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43629 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43630 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
43632 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43633 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43640 C COLLECTING THE RELEVANT OVERALL FACTORS:
43641 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
43642 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
43643 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43644 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43645 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43646 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43647 C ALPHAS IS ALPHA_STRONG;
43648 C SW2 IS SIN(THETA_W)**2.
43651 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43653 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43654 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43655 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43657 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43658 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43660 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43662 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43663 S = 2*PYTBHS(Q1,Q2)
43670 C TOP WIDTH CALCULATION
43671 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43672 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43673 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43674 A1INV= S -2*P1Q1 -2*P1Q2
43675 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43676 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43677 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
43678 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43679 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43680 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43681 C NOW COMES THE AMP**2:
43682 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
43683 C THE EXPRESSIONS BELOW
43684 YY(1, 1) = -16*A**2*A2**2*MB*MT+
43685 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
43686 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
43687 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
43688 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43689 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43690 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
43691 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
43692 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
43693 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
43694 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
43695 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
43696 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
43697 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
43698 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43699 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43700 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
43701 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
43702 &32*A2**2*MB**2*P1P2*V**2/S+
43703 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
43704 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
43705 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
43706 YY(1, 1)=2*YY(1, 1)
43708 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
43709 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
43710 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43711 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43712 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
43713 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
43714 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
43715 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43716 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
43717 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43718 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
43719 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43720 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
43721 &64*A**2*A1*A2*MB*MT*P1P2/S+
43722 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
43723 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
43724 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
43725 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
43726 &64*A**2*A1*A2*P1Q1*P2Q1/S-
43727 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
43728 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
43729 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
43730 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
43731 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
43732 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
43733 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
43734 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
43735 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
43736 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
43737 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
43738 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43739 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43740 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
43741 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
43742 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
43743 &32*A1*A2*P1P2*P1Q1*V**2/S+
43744 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
43745 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
43746 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
43747 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
43750 YY(2, 2) =-16*A**2*A12*MB*MT+
43751 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
43752 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
43753 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
43754 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
43755 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
43756 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
43757 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
43758 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
43759 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
43760 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
43761 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
43762 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
43763 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
43764 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
43765 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
43766 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
43767 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
43768 &32*A12*MT**2*P2Q2*V**2/S-
43769 &32*A12*P1Q2*P2Q2*V**2/S
43770 YY(2, 2)=2*YY(2, 2)
43772 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
43773 AMP2= FACT*PS*VTB**2*RES
43776 C=====================================================================
43777 C ************* FUNCTION SCALAR PRODUCTS *************************
43778 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
43779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43780 IMPLICIT INTEGER(I-N)
43781 DIMENSION A(4),B(4)
43784 DUM=DUM-A(ID)*B(ID)
43790 C*********************************************************************
43793 C...Initializes supersymmetry: finds sparticle masses and
43794 C...branching ratios and stores this information.
43795 C...AUTHOR: STEPHEN MRENNA
43796 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
43800 C...Double precision and integer declarations.
43801 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43802 IMPLICIT INTEGER(I-N)
43803 INTEGER PYK,PYCHGE,PYCOMP
43804 C...Parameter statement to help give large particle numbers.
43805 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43806 &KEXCIT=4000000,KDIMEN=5000000)
43808 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43809 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43810 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43811 COMMON/PYDAT4/CHAF(500,2)
43813 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43814 COMMON/PYINT4/MWID(500),WIDS(500,5)
43815 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43816 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43817 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43818 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43819 COMMON/PYHTRI/HHH(7)
43820 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
43821 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
43822 &/PYMSSM/,/PYMSRV/,/PYSSMT/
43824 C...Local variables.
43825 DOUBLE PRECISION ALFA,BETA
43826 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
43827 INTEGER I,J,J1,I1,K1
43828 INTEGER KC,LKNT,IDLAM(400,3)
43829 DOUBLE PRECISION XLAM(0:400)
43830 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
43831 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
43832 DOUBLE PRECISION DELM,XMDIF
43833 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
43834 DOUBLE PRECISION ARG,SGNMU,R
43837 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
43840 &1000001,2000001,1000002,2000002,1000003,2000003,
43841 &1000004,2000004,1000005,2000005,1000006,2000006,
43842 &1000011,2000011,1000012,2000012,1000013,2000013,
43843 &1000014,2000014,1000015,2000015,1000016,2000016,
43844 &1000021,1000022,1000023,1000025,1000035,1000024,
43845 &1000037,1000039, 25, 35, 36, 37,
43846 & 6, 24, 45, 46,1000045, 9*0/
43849 C...Automatically read QNUMBERS, MASS, and DECAY tables
43850 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
43852 CALL PYSLHA(0,0,IFAIL)
43853 CALL PYSLHA(5,0,IFAIL)
43855 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
43857 C...Do nothing further if SUSY not requested
43859 IF(IMSSM.EQ.0) RETURN
43861 C...Save copy of MWID(KC) and MDCY(KC,1) values before
43862 C...they are set to zero for the LSP.
43869 MDCYSU(I)=MDCY(KC,1)
43873 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
43877 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
43879 MDCY(KC,1)=MDCYSU(I)
43883 C...First part of routine: set masses and couplings.
43885 C...Reset mixing values in sfermion sector to pure left/right.
43893 C...Add NMSSM states if NMSSM switched on, and change old names.
43894 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
43895 C... Switch on NMSSM
43896 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43926 DO 123 KCT=100,MSTU(6)
43927 IF(KCHG(KCT,4).GT.100) KCN=KCT
43933 C... Set stable for now
43939 CHAF(KCN,1)='~chi_50'
43943 C...Read spectrum from SLHA file.
43944 IF (IMSSM.EQ.11) THEN
43945 CALL PYSLHA(1,0,IFAIL)
43948 C...Common couplings.
43953 COS2B=COS(2D0*BETA)
43959 C...Define sparticle masses for a general MSSM simulation.
43960 IF(IMSSM.EQ.1) THEN
43961 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43963 KC=PYCOMP(KSUSY1+I)
43964 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43965 KC=PYCOMP(KSUSY2+I)
43966 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43967 KC=PYCOMP(KSUSY1+I+1)
43968 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43969 KC=PYCOMP(KSUSY2+I+1)
43970 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43972 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43973 IF(XARG.LT.0D0) THEN
43974 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43975 & ' FROM THE SUM RULE. '
43976 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43982 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
43983 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
43984 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
43985 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
43987 IF(IMSS(8).EQ.1) THEN
43992 C...Alternatively derive masses from SUGRA relations.
43993 ELSEIF(IMSSM.EQ.2) THEN
43997 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44006 C...Add in extra D-term contributions.
44007 IF(IMSS(7).EQ.1) THEN
44012 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44013 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44014 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44015 WRITE(MSTU(11),*) 'C DX = ',DX
44016 WRITE(MSTU(11),*) 'C DY = ',DY
44017 WRITE(MSTU(11),*) 'C DS = ',DS
44018 WRITE(MSTU(11),*) 'C '
44019 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44020 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44021 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44022 DQ2=DY/6D0-DX/3D0-DS/3D0
44023 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44024 DD2=DY/3D0+DX-2D0*DS/3D0
44025 DL2=-DY/2D0+DX-2D0*DS/3D0
44026 DE2=DY-DX/3D0-DS/3D0
44027 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44028 DHD2=-DY/2D0-2D0*DX/3D0+DS
44029 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44031 DMA2 = 2D0*DMU2+DHU2+DHD2
44033 KC=PYCOMP(KSUSY1+I)
44034 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44035 KC=PYCOMP(KSUSY2+I)
44036 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44037 KC=PYCOMP(KSUSY1+I+1)
44038 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44039 KC=PYCOMP(KSUSY2+I+1)
44040 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44043 KC=PYCOMP(KSUSY1+I)
44044 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44045 KC=PYCOMP(KSUSY2+I)
44046 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44047 KC=PYCOMP(KSUSY1+I+1)
44048 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44050 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44051 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44054 SGNMU=SIGN(1D0,RMSS(4))
44055 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44056 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44057 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44058 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44059 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44060 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44061 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44062 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44063 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44064 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44065 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44066 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44067 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44070 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44071 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44072 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44073 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44074 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44075 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
44076 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
44077 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
44080 C...Fix the third generation sfermions.
44083 C...Fix the neutralino--chargino--gluino sector.
44086 C...Fix the Higgs sector.
44089 C...Choose the Gunion-Haber convention.
44093 C...Print information on mass parameters.
44094 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
44095 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44096 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44097 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
44098 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
44099 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
44100 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
44101 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
44102 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
44103 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
44104 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44106 IF(IMSS(20).EQ.1) THEN
44107 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44108 WRITE(MSTU(11),*) ' DEBUG MODE '
44109 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
44110 & UMIX(2,1),UMIX(2,2)
44111 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
44112 & UMIXI(2,1),UMIXI(2,2)
44113 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
44114 & VMIX(2,1),VMIX(2,2)
44115 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
44116 & VMIXI(2,1),VMIXI(2,2)
44117 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
44118 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
44119 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
44120 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
44121 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
44122 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
44123 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
44124 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
44125 WRITE(MSTU(11),*) ' ALFA = ',ALFA
44126 WRITE(MSTU(11),*) ' BETA = ',BETA
44127 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
44128 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
44129 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44132 C...Set up the Higgs couplings - needed here since initialization
44133 C...in PYINRE did not yet occur when PYWIDT is called below.
44145 C2B=COSB**2-SINB**2
44146 C...tanb (used for H+)
44150 C...Coupling to d-type quarks
44151 PARU(161)=SINA/COSB
44152 C...Coupling to u-type quarks
44153 PARU(162)=-COSA/SINB
44154 C...Coupling to leptons
44155 PARU(163)=PARU(161)
44159 PARU(165)=PARU(164)
44162 C...Coupling to d-type quarks
44163 PARU(171)=-COSA/COSB
44164 C...Coupling to u-type quarks
44165 PARU(172)=-SINA/SINB
44166 C...Coupling to leptons
44167 PARU(173)=PARU(171)
44171 PARU(175)=PARU(174)
44173 IF(IMSS(4).GE.2) THEN
44174 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
44176 HHH(3)=HHH(3)+HHH(4)+HHH(5)
44177 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
44178 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
44179 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
44180 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
44184 IF(IMSS(4).GE.2) THEN
44185 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
44187 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
44188 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
44189 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
44190 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
44193 IF(IMSS(4).GE.2) THEN
44194 PARU(177)=COS(2D0*BE)*COS(BE+AL)
44196 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
44197 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
44198 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
44199 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
44202 IF(IMSS(4).GE.2) THEN
44203 PARU(178)=PARU(177)
44205 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
44208 C...Coupling to d-type quarks
44210 C...Coupling to u-type quarks
44211 PARU(182)=1D0/PARU(181)
44212 C...Coupling to leptons
44213 PARU(183)=PARU(181)
44216 C...Coupling to Z h
44217 PARU(186)=COS(BE-AL)
44218 C...Coupling to Z H
44219 PARU(187)=SIN(BE-AL)
44225 C...Coupling to W h
44226 PARU(195)=COS(BE-AL)
44228 C...Tell that all Higgs couplings have been set.
44231 C...Set R-Violating couplings.
44232 C...Set lambda couplings to common value or "natural values".
44233 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
44234 VIR3=1D0/(126D0)**3
44238 IF (IRI.NE.IRJ) THEN
44239 IF (IRI.LT.IRJ) THEN
44240 RVLAM(IRI,IRJ,IRK)=RMSS(51)
44241 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
44242 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
44243 & PMAS(9+2*IRK,1)*VIR3)
44245 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
44248 RVLAM(IRI,IRJ,IRK)=0D0
44254 C...Set lambda' couplings to common value or "natural values".
44255 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
44256 VIR3=1D0/(126D0)**3
44260 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
44261 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
44262 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
44263 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
44268 C...Set lambda'' couplings to common value or "natural values".
44269 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
44270 VIR3=1D0/(126D0)**3
44274 IF (IRJ.NE.IRK) THEN
44275 IF (IRJ.LT.IRK) THEN
44276 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
44277 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
44278 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
44279 & PMAS(2*IRK-1,1)*VIR3)
44281 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
44284 RVLAMB(IRI,IRJ,IRK) = 0D0
44291 C...Antisymmetrize couplings set by user
44292 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
44296 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
44297 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
44298 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
44300 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
44301 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
44302 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
44309 C...Write spectrum to SLHA file
44310 IF (IMSS(23).NE.0) THEN
44312 CALL PYSLHA(3,0,IFAIL)
44315 C...Second part of routine: set decay modes and branching ratios.
44317 C...Allow chi10 -> gravitino + gamma or not.
44318 KC=PYCOMP(KSUSY1+39)
44319 IF( IMSS(11) .NE. 0 ) THEN
44320 PMAS(KC,1)=RMSS(21)/1D9
44323 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
44324 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
44326 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
44327 & ' ALLOWING SUSY LLE DECAYS'
44328 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
44329 & ' ALLOWING SUSY LQD DECAYS'
44330 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
44331 & ' ALLOWING SUSY UDD DECAYS'
44332 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
44333 & ' --- Warning: R-Violating couplings possibly',
44334 & ' incompatible with proton decay'
44340 C...Loop over sparticle and Higgs species.
44341 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
44342 C...Find the LSP or NLSP for a gravitino LSP
44347 IF(KF.EQ.1000039) GOTO 300
44349 IF(PMAS(KC,1).LT.PMLSP) THEN
44355 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
44357 IF (KF.EQ.0) GOTO 370
44361 C...Check if there are any decays listed for this sparticle
44363 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
44365 CALL PYSLHA(2,KF,IFAIL)
44366 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
44367 ELSEIF (I.GE.37) THEN
44371 C...Sfermion decays.
44373 C...First check to see if sneutrino is lighter than chi10.
44374 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
44375 & PMAS(KC,1).LT.PMCHI1) THEN
44377 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
44381 ELSEIF(I.EQ.25) THEN
44382 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
44383 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
44385 C...Neutralino decays.
44386 ELSEIF(I.GE.26.AND.I.LE.29) THEN
44387 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
44388 C...chi10 stable or chi10 -> gravitino + gamma.
44389 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
44395 C...Chargino decays.
44396 ELSEIF(I.GE.30.AND.I.LE.31) THEN
44397 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
44399 C...Gravitino is stable.
44400 ELSEIF(I.EQ.32) THEN
44405 ELSEIF(I.GE.33.AND.I.LE.36) THEN
44406 C...Calculate decays to non-SUSY particles.
44407 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
44412 DO 330 I1=1,MDCY(KC,3)
44414 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
44415 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
44417 XLAM(0)=XLAM(0)+XLAM(I1)
44419 IDLAM(I1,J1)=KFDP(K1,J1)
44423 C...Add the decays to SUSY particles.
44424 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
44426 C...Zero the branching ratios for use in loop mode
44427 C...thanks to K. Matchev (FNAL)
44428 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44432 C...Set stable particles.
44440 C...Store branching ratios in the standard tables.
44442 IDC=MDCY(KC,2)+MDCY(KC,3)-1
44448 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
44449 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
44450 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
44451 BRAT(IDC)=XLAM(IL)/XLAM(0)
44453 IF(MDME(IDC,1).GE.1) THEN
44454 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
44455 & PMAS(PYCOMP(KFDP(IDC,2)),1)
44456 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
44457 & PMAS(PYCOMP(KFDP(IDC,3)),1)
44460 IF(XMDIF.GE.0D0) THEN
44461 DELM=MIN(DELM,XMDIF)
44463 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
44464 WRITE(MSTU(11),*) ' KF = ',KF
44465 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
44469 ELSEIF(IDC.EQ.IDCSV) THEN
44470 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
44471 & 'channel not recognized:'
44472 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
44479 C...Store width, cutoff and lifetime.
44481 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
44482 PMAS(KC,3)=PMAS(KC,2)*10D0
44484 PMAS(KC,3)=0.95D0*DELM
44486 IF(PMAS(KC,2).NE.0D0) THEN
44487 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
44489 C...Write decays to SLHA file
44490 IF (IMSS(24).NE.0) THEN
44492 CALL PYSLHA(4,KF,IFAIL)
44500 C*********************************************************************
44503 C...Read/write spectrum or decay data from SLHA standard file(s).
44506 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
44507 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
44508 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
44509 C... (KFORIG=0 : read all decay tables)
44510 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
44511 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
44512 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
44513 C... (KFORIG=0 : read all MASS entries)
44515 C...Recent updates:
44516 C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
44517 C... : Corrected QNUMBERS name-formation; root only until space
44518 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
44520 C...Double precision and integer declarations.
44521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44522 IMPLICIT INTEGER(I-N)
44523 INTEGER PYK,PYCHGE,PYCOMP
44524 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44525 &KEXCIT=4000000,KDIMEN=5000000)
44527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44529 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44530 COMMON/PYDAT4/CHAF(500,2)
44532 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44533 CHARACTER*40 ISAVER,VISAJE
44534 COMMON/PYINT4/MWID(500),WIDS(500,5)
44535 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
44537 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44538 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44539 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44540 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44541 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
44543 C...Local arrays, character variables and data.
44544 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
44545 & AU(3,3),AD(3,3),AE(3,3)
44546 COMMON/PYLH3C/CPRO(2),CVER(2)
44547 C...The common block of new states (QNUMBERS / PARTICLE)
44548 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44549 C...- NQNUM : Number of QNUMBERS blocks that have been read in
44550 C...- KQNUM(I,0) : KF of new state
44551 C...- KQNUM(I,1) : 3 times electric charge
44552 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
44553 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
44554 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
44555 C...- KQNUM(I,5:9) : space available for further quantum numbers
44556 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
44557 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
44558 C...MMOD: flags to set for each block read in.
44559 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
44560 C...MSPC: Flags to set for each block read in.
44561 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
44562 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
44563 C...11: AD 12: AE 13: YU 14: YD 15: YE
44564 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
44565 CHARACTER CPRO*12,CVER*12,CHNLIN*6
44566 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
44567 CHARACTER CHINL*120,CHKF*9,CHTMP*16
44570 C...Date of last Change
44571 PARAMETER (DOC='05 Nov 2007')
44572 C...Local arrays and initial values
44573 DIMENSION IDC(5),KFSUSY(50)
44582 &1000001,1000002,1000003,1000004,1000005,1000006,
44583 &2000001,2000002,2000003,2000004,2000005,2000006,
44584 &1000011,1000012,1000013,1000014,1000015,1000016,
44585 &2000011,2000012,2000013,2000014,2000015,2000016,
44586 &1000021,1000022,1000023,1000025,1000035,1000024,
44587 &1000037,1000039, 25, 35, 36, 37,
44588 & 6, 24, 45, 46,1000045, 9*0/
44590 RMFUN(IP)=PMAS(PYCOMP(IP),1)
44592 C...Shorthand for spectrum and decay table unit numbers
44596 C...Default for LHEF input: read header information
44597 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
44598 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
44599 IF (IMSS21.EQ.MSTP(161)) MLHEF=1
44600 IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
44603 IF (NHELLO.EQ.0) THEN
44604 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
44605 WRITE(MSTU(11),5000) DOC
44610 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
44613 IF (MUPDA.EQ.2) LFN=IMSS22
44614 IF (MUPDA.EQ.3) LFN=IMSS(23)
44615 IF (MUPDA.EQ.4) LFN=IMSS(24)
44616 C...Flag that we have not yet found whatever we were asked to find.
44619 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
44621 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
44625 C...If reading LHEF header, start by rewinding file
44626 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
44628 C...If told to read spectrum, first zero all previous information.
44629 IF (MUPDA.EQ.1) THEN
44630 C...Zero all block read flags
44635 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
44637 KC=PYCOMP(KFSUSY(ISUSY))
44640 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
44648 IF (J.LE.2.AND.L.LE.2) THEN
44655 C...Zero signed masses.
44657 IF (J.LE.2) SMW(J)=0D0
44660 C...If reading decays, reset PYTHIA decay counters.
44661 ELSEIF (MUPDA.EQ.2) THEN
44662 C...Check if DECAY for this KF already read
44663 IF (KFORIG.NE.0) THEN
44664 DO 140 IDEC=1,NDECAY
44665 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
44674 DO 150 KC=1,MSTU(6)
44675 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
44676 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
44678 ELSEIF (MUPDA.EQ.5) THEN
44679 C...Zero block read flags
44686 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
44687 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
44688 C...Initialize program and version strings
44689 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
44694 C...Initialize read loop
44698 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
44700 READ(LFN,'(A120)',END=400) CHINL
44701 C...Count which line number we're at.
44703 WRITE(CHNLIN,'(I6)') NLINE
44705 C...Skip comment and empty lines without processing.
44706 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
44708 C...We assume all upper case below. Rewrite CHINL to all upper case.
44712 IF (CHINL(INL:INL).NE.'#') THEN
44714 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
44716 C...Extra safety. Chek for sensible input on line
44717 IF (IGOOD.EQ.0) THEN
44719 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
44722 IF (INL.LT.120) GOTO 180
44724 IF (IGOOD.EQ.0) GOTO 170
44726 C...Exit when first <event> tag reached in LHEF file
44728 IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
44734 C...Check for BLOCK begin statement (spectrum).
44735 IF (CHINL(1:5).EQ.'BLOCK') THEN
44737 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
44738 C...Check if another of this type of block was already read.
44739 C...(logarithmic interpolation not yet implemented, so duplicates always
44741 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
44742 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
44743 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
44744 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
44745 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
44746 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
44747 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
44748 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
44749 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
44750 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
44751 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
44752 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
44753 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
44754 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
44755 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
44756 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
44757 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
44758 C...Check for new particles
44759 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44761 MSPC(19)=MSPC(19)+1
44763 READ(CHBLCK(9:60),*) KFQ
44766 IF (KQNUM(MQ,0).EQ.KFQ) THEN
44771 IF (NHELLO.EQ.0) THEN
44772 WRITE(MSTU(11),5000) DOC
44775 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44776 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
44780 MSPC(19)=MSPC(19)+1
44782 C...Only read in new codes (also OK to overwrite if KF > 3000000)
44783 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
44785 DO 230 KCT=100,MSTU(6)
44786 IF(KCHG(KCT,4).GT.100) KCQ=KCT
44792 C...First write PDG code as name
44794 WRITE(CHTMP,'(A)') CHTMP(2:10)
44795 C...Then look for real name
44798 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
44800 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
44803 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
44804 IF (IEND.LT.59) THEN
44805 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
44806 IF (CHDUM.NE.' ') CHTMP=CHDUM
44808 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
44810 C...Set stable for now
44818 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
44819 & CHAF(KCQ,1), '. Entry ignored.'
44823 C...Finalize this line and read next.
44825 C...Check for DECAY begin statement (decays).
44826 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
44830 C...Read KF code and WIDTH
44832 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
44837 C...If this is not the KF we're looking for...
44838 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
44839 C...Set block skip flag and read next line.
44843 C...Check whether decay table for this particle already read in
44844 DO 280 IDECAY=1,NDECAY
44845 IF (KFDEC(IDECAY).EQ.KF) THEN
44852 C...Determine PYTHIA KC code of particle
44858 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
44862 IF (KCREP.NE.0) THEN
44863 C...Particle is already known. Don't do anything yet.
44865 C... Add new particle. Actually, this should not happen.
44866 C... New particles should be added already when reading the spectrum
44867 C... information, so go under previously stable category.
44872 IF (WIDTH.LE.0D0) THEN
44873 C...Stable (i.e. LSP)
44875 & '* (PYSLHA:) Reading in SLHA stable particle ',
44876 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
44877 IF (WIDTH.LT.0D0) THEN
44878 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
44885 C...Ignore any decay lines that may be present for this KF
44892 C...Finalize and start reading in decay modes.
44894 ELSEIF (MOD(MERR,10).GE.6) THEN
44895 C...If ignore block flag set, skip directly to next line.
44900 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
44901 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44903 READ(CHINL,*) INDX, IVAL
44904 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
44905 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
44906 IF (INDX.EQ.3) KCHG(KCQ,2)=0
44907 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
44908 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
44909 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
44910 IF (INDX.EQ.4) THEN
44912 IF (IVAL.EQ.1) THEN
44914 IF (CHTMP.EQ.' ') THEN
44915 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
44916 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
44920 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
44921 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
44922 CHTMP(ILAST:ILAST)='-'
44924 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
44933 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
44934 C...MASS: Mass spectrum
44935 IF (CHBLCK(1:4).EQ.'MASS') THEN
44936 READ(CHINL,*) KF, VAL
44939 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
44940 C...Read in masses for anything
44943 C...Don't read in masses for the light quarks
44944 IF (IABS(KF).LE.3) THEN
44945 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44946 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
44952 PMAS(KC,1) = ABS(VAL)
44953 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
44954 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44955 & ' * (PYSLHA:) Reading in MASS entry for KF =',
44956 & KF, ', pole mass =', VAL
44960 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
44961 IF (KF.EQ.1000022) SMZ(1)=VAL
44962 IF (KF.EQ.1000023) SMZ(2)=VAL
44963 IF (KF.EQ.1000025) SMZ(3)=VAL
44964 IF (KF.EQ.1000035) SMZ(4)=VAL
44965 IF (KF.EQ.1000024) SMW(1)=VAL
44966 IF (KF.EQ.1000037) SMW(2)=VAL
44968 ELSEIF (MUPDA.EQ.5) THEN
44971 C... MODSEL: Model selection and global switches
44972 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
44973 READ(CHINL,*) INDX, IVAL
44974 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44975 IF (IMSS(1).EQ.0) IMSS(1)=11
44978 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
44979 C... Switch on NMSSM
44980 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
44981 IMSS(13)=MAX(1,IMSS(13))
44982 C... Add NMSSM states if not already done
45012 DO 310 KCT=100,MSTU(6)
45013 IF(KCHG(KCT,4).GT.100) KCN=KCT
45019 C... Set stable for now
45025 CHAF(KCN,1)='~chi_50'
45031 ELSEIF (MUPDA.EQ.5) THEN
45032 C...If MUPDA = 5, skip all except MASS, return if MODSEL
45034 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
45035 & CHBLCK(1:8).EQ.'PARTICLE') THEN
45036 C...Don't print a warning for QNUMBERS when reading spectrum
45038 C...MINPAR: Minimal model parameters
45039 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
45040 READ(CHINL,*) INDX, VAL
45041 IF (INDX.LE.100.AND.INDX.GT.0) THEN
45047 IF (MMOD(3).NE.0) THEN
45049 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45053 IF (INDX.EQ.3) RMSS(5)=VAL
45054 C...EXTPAR: non-minimal model parameters.
45055 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
45056 IF (MMOD(1).NE.0) THEN
45057 READ(CHINL,*) INDX, VAL
45058 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45066 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45070 IF (INDX.EQ.25) RMSS(5)=VAL
45071 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
45072 READ(CHINL,*) INDX, VAL
45073 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
45075 ELSEIF (INDX.EQ.4) THEN
45076 PMAS(PYCOMP(23),1)=VAL
45077 ELSEIF (INDX.EQ.6) THEN
45078 PMAS(PYCOMP(6),1)=VAL
45080 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
45081 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
45082 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
45084 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45086 IF (CHBLCK(5:6).EQ.'IM') IM=1
45087 320 READ(CHINL,*) INDX1, INDX2, VAL
45088 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
45089 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
45090 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
45092 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
45093 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
45094 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
45096 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
45097 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
45098 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
45100 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
45101 $ .CHBLCK(1:4).EQ.'STAU') THEN
45102 IF (CHBLCK(1:4).EQ.'STOP') THEN
45105 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
45108 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
45112 C...Set SFMIX element
45113 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
45114 MSPC(ISPC)=MSPC(ISPC)+1
45116 C...Running parameters
45117 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
45118 READ(CHBLCK(8:25),*,ERR=620) Q
45119 READ(CHINL,*) INDX, VAL
45121 IF (INDX.EQ.1) THEN
45127 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
45128 READ(CHINL,*,ERR=630) VAL
45130 MSPC(17)=MSPC(17)+1
45131 C...Higgs parameters set manually or with FeynHiggs.
45132 IMSS(4)=MAX(2,IMSS(4))
45133 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
45134 & .CHBLCK(1:2).EQ.'AE') THEN
45135 READ(CHBLCK(9:26),*,ERR=620) Q
45136 READ(CHINL,*) INDX1, INDX2, VAL
45137 IF (CHBLCK(2:2).EQ.'U') THEN
45138 AU(INDX1,INDX2)=VAL
45139 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
45140 MSPC(11)=MSPC(11)+1
45141 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
45142 AD(INDX1,INDX2)=VAL
45143 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
45144 MSPC(10)=MSPC(10)+1
45145 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
45146 AE(INDX1,INDX2)=VAL
45147 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
45148 MSPC(12)=MSPC(12)+1
45152 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
45153 IF (MSPC(18).EQ.0) THEN
45154 READ(CHBLCK(9:25),*,ERR=620) Q
45157 READ(CHINL,*) INDX, VAL
45159 MSPC(18)=MSPC(18)+1
45160 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
45162 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
45163 & .CHBLCK(1:2).EQ.'YE') THEN
45165 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
45166 READ(CHINL(1:6),*) INDX
45170 IF (CHINL(IT:IT).EQ.' ') GOTO 330
45171 C...Don't read index
45172 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
45176 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
45177 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
45179 C... Set unrecognized block flag.
45184 C...Read in decay information
45185 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
45186 C...Read new decay chanel
45187 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
45189 C...Read in branching ratio and number of daughters for this mode.
45190 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
45191 READ(CHINL(4:50),*,ERR=600) DUM, NDA
45193 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
45194 & '(PYSLHA:) Decay data arrays full by KF ='
45196 C...If first decay channel, set decays start point in decay table
45197 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
45198 IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
45199 & '* (PYSLHA:) Reading in SLHA decay table for ',
45200 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
45201 C...Set particle parameters (mass set when reading BLOCK MASS above)
45203 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
45205 & '* Note: the Pythia gg->h/H/A cross section'//
45206 & ' is proportional to the h/H/A->gg width'
45209 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
45214 C...Add to list of DECAY blocks currently read
45220 C... Count up number of decay modes for this particle
45221 MDCY(KC,3)=MDCY(KC,3)+1
45222 C... Read in decay daughters.
45223 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
45224 C... Flip sign if reading antiparticle decays (if antipartner exists)
45226 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
45227 & IDC(IDA)=MPSIGN*IDC(IDA)
45229 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
45231 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
45232 BRSUM=BRSUM+ABS(BRAT(NDC))
45233 BRAT(NDC)=ABS(BRAT(NDC))
45236 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
45238 IDC(IDA)=IDC(IDA+1)
45243 IF (IFLIP.GT.0) GOTO 350
45244 C...Treat as ordinary decay, no fancy stuff.
45247 IF (IDA.LE.NDA) THEN
45248 KFDP(NDC,IDA)=IDC(IDA)
45253 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
45254 C & (KFDP(NDC,J),J=1,NDA)
45256 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
45261 ELSEIF(CHINL(1:1).EQ.'+') THEN
45263 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
45270 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
45271 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
45274 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
45275 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
45276 & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
45277 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
45278 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
45279 & //CHBLCK(1:INL)//'... on line'//CHNLIN
45280 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
45281 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
45282 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
45283 & //'... on line'//CHNLIN
45284 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
45285 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
45286 & /CHBLCK(1:INL)//'... on line'//CHNLIN
45287 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
45290 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
45291 & CHTMP(1:9)//' on line'//CHNLIN
45293 C...Iterate read loop
45296 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
45297 & ', ignoring subsequent lines.'
45298 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
45301 C...End of read loop
45303 C...Set flag that KC codes have been rearranged.
45307 C...Perform possible tests that new information is consistent.
45308 IF (MUPDA.EQ.1) THEN
45311 C...Check Z and top masses
45312 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
45313 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45314 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
45316 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
45317 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45318 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
45324 C...Don't complain about right-handed neutrinos
45325 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
45327 C...Only check gravitino in GMSB scenarios
45328 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
45330 IF (PMAS(KC,1).EQ.0D0) THEN
45333 & ,'(PYSLHA:) No mass information found for KF ='
45337 C...Check mixing matrices (MSSM only)
45338 IF (IMSS(13).EQ.0) THEN
45339 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
45340 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
45341 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
45342 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
45343 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
45344 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
45345 IF (MSPC(5).NE.4) CALL PYERRM(9
45346 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
45347 IF (MSPC(6).NE.4) CALL PYERRM(9
45348 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
45349 IF (MSPC(7).NE.4) CALL PYERRM(9
45350 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
45351 IF (MSPC(8).LT.1) CALL PYERRM(9
45352 & ,'(PYSLHA:) Too few elements in HMIX')
45353 IF (MSPC(10).EQ.0) CALL PYERRM(9
45354 & ,'(PYSLHA:) Missing A_b trilinear coupling')
45355 IF (MSPC(11).EQ.0) CALL PYERRM(9
45356 & ,'(PYSLHA:) Missing A_t trilinear coupling')
45357 IF (MSPC(12).EQ.0) CALL PYERRM(9
45358 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
45359 IF (MSPC(17).LT.1) CALL PYERRM(9
45360 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
45362 C...Check wavefunction normalizations.
45365 IF (MSPC(ISPC).EQ.4) THEN
45367 IF (ISPC.EQ.7) KFSM=15
45368 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
45370 IF (ABS(1D0-CHECK).GT.1D-3) THEN
45373 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
45378 C...Neutralinos + charginos
45387 CN1=CN1+ZMIX(J,L)**2
45388 CN2=CN2+ZMIX(L,J)**2
45389 IF (J.LE.2.AND.L.LE.2) THEN
45390 CU1=CU1+UMIX(J,L)**2
45391 CU2=CU2+UMIX(L,J)**2
45392 CV1=CV1+VMIX(J,L)**2
45393 CV2=CV2+VMIX(L,J)**2
45396 C...NMIX normalization
45397 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
45398 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
45400 & '(PYSLHA:) NMIX: Inconsistent normalization.')
45401 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
45403 C...UMIX, VMIX normalizations
45404 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
45406 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
45408 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
45409 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
45412 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
45414 & '(PYSLHA:) VMIX: Inconsistent normalization.')
45415 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
45421 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
45422 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
45423 & '* PYSLHA: No spectrum inconsistencies were found.'
45425 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
45426 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
45427 & ,' Warning: one or more (serious)'//
45428 & ' inconsistencies were found in the spectrum !'
45429 & ,' Read the error messages above and check your'//
45432 C...Increase precision in Higgs sector using FeynHiggs
45433 IF (IMSS(4).EQ.3) THEN
45434 C...FeynHiggs needs MSOFT.
45436 IF (MSPC(18).EQ.0) THEN
45437 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
45438 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
45439 & ' Cannot call FeynHiggs.'
45442 WRITE(MSTU(11),'(1x,/1x,A/)')
45443 & '* (PYSLHA:) Now calling FeynHiggs.'
45445 IF (IERR.NE.0) IMSS(4)=2
45448 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
45450 IF (KFORIG.NE.0) IBEG=NDECAY
45451 DO 490 IDECAY=IBEG,NDECAY
45454 WRITE(CHKF,8300) KF
45455 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
45456 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
45457 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
45458 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
45462 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45463 IF(MDME(IDA,2).GT.80) GOTO 460
45465 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
45469 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
45471 ELSEIF(PYCOMP(KP).EQ.0) THEN
45476 PMS=PMS-PMAS(KPC,1)
45477 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
45481 IF(KQ.NE.0) MERR=MAX(2,MERR)
45482 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
45484 IF(MERR.EQ.3) CALL PYERRM(17,
45485 & '(PYSLHA:) Unknown particle code in decay of KF ='
45487 IF(MERR.EQ.2) CALL PYERRM(17,
45488 & '(PYSLHA:) Charge not conserved in decay of KF ='
45490 IF(MERR.EQ.1) CALL PYERRM(7,
45491 & '(PYSLHA:) Kinematically unallowed decay of KF ='
45493 BRSUM=BRSUM+BRAT(IDA)
45494 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
45496 C...Check branching ratio sum.
45497 IF (BROPN.LE.0D0) THEN
45498 C...If zero, set stable.
45499 WRITE(CHTMP,8500) BROPN
45501 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
45502 & CHTMP(9:16)//'. Changed to stable.')
45505 C...If BR's > 1, rescale.
45506 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
45507 WRITE(CHTMP,8500) BRSUM
45508 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
45509 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
45510 & ' ; sum was'//CHTMP(9:16)//'.')
45512 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45513 IF(MDME(IDA,2).GT.80) GOTO 470
45514 BRAT(IDA)=FAC*BRAT(IDA)
45516 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
45517 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
45518 WRITE(CHTMP,8500) BRSUM
45519 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
45520 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
45521 & CHTMP(9:16)//'. Dummy mode will be inserted.')
45522 C...Move table and insert dummy mode
45523 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45525 BRAT(NDC)=BRAT(IDA)
45526 KFDP(NDC,1)=KFDP(IDA,1)
45527 KFDP(NDC,2)=KFDP(IDA,2)
45528 KFDP(NDC,3)=KFDP(IDA,3)
45529 KFDP(NDC,4)=KFDP(IDA,4)
45530 KFDP(NDC,5)=KFDP(IDA,5)
45531 MDME(NDC,1)=MDME(IDA,1)
45534 BRAT(NDC)=1D0-BRSUM
45543 MDCY(KC,3)=MDCY(KC,3)+1
45544 MDCY(KC,2)=NDC-MDCY(KC,3)+1
45550 C...WRITE SPECTRUM ON SLHA FILE
45551 ELSEIF(MUPDA.EQ.3) THEN
45552 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
45553 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
45558 PARMIN(4)=SIGN(1D0,RMSS(4))
45562 WRITE(LFN,7000) 'SLHA MSSM spectrum'
45563 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
45565 WRITE(LFN,7010) 'MODSEL', 'Model selection'
45566 WRITE(LFN,7110) 1, MODSEL(1)
45567 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
45568 IF (MODSEL(1).EQ.1) THEN
45569 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
45570 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
45571 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45572 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45573 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
45574 ELSEIF(MODSEL(2).EQ.2) THEN
45575 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
45576 WRITE(LFN,7210) 2, PARMIN(2), 'M'
45577 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45578 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45579 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
45580 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
45582 WRITE(LFN,7000) ' '
45583 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
45587 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
45589 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
45590 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
45591 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
45592 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
45593 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
45594 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
45595 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
45597 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
45601 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
45602 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
45603 WRITE(LFN,7210) 1, RMSS(4),'mu'
45604 WRITE(LFN,7010) 'ALPHA',' '
45605 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
45606 WRITE(LFN,7020) 'AU',RMSUSY
45607 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
45608 WRITE(LFN,7020) 'AD',RMSUSY
45609 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
45610 WRITE(LFN,7020) 'AE',RMSUSY
45611 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
45612 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
45613 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
45614 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
45615 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
45616 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
45617 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
45618 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
45619 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
45620 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
45621 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
45622 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
45623 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
45624 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
45625 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
45626 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
45627 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
45630 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
45633 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
45636 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
45639 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
45642 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
45645 WRITE(LFN,7010) 'SPINFO'
45646 IF (IMSS(1).EQ.2) THEN
45649 ELSEIF (IMSS(1).EQ.12) THEN
45652 CVER(1)=ISAVER(1:12)
45654 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
45655 WRITE(LFN,7310) 2, CVER(1), 'Version number'
45658 C...Print user information about spectrum
45659 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
45660 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
45661 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
45662 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
45663 IF (MUPDA.EQ.1) THEN
45664 WRITE(MSTU(11),5020) LFN
45666 WRITE(MSTU(11),5010) LFN
45669 WRITE(MSTU(11),5400)
45670 WRITE(MSTU(11),5500) 'Pole masses'
45671 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
45672 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
45673 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
45674 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
45675 IF (IMSS(13).EQ.0) THEN
45676 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
45677 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
45678 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
45679 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
45680 & CHAF(37,1), ' ', ' ',' ',' ',
45681 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
45682 ELSEIF (IMSS(13).EQ.1) THEN
45691 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
45692 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
45693 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
45694 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
45695 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
45696 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
45697 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
45698 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
45699 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
45702 WRITE(MSTU(11),5400)
45703 WRITE(MSTU(11),5500) 'Mixing structure'
45704 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45705 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45706 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45707 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45708 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45709 & ),(SFMIX(15,J),J=3,4)
45710 WRITE(MSTU(11),5400)
45711 WRITE(MSTU(11),5500) 'Couplings'
45712 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
45713 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
45714 WRITE(MSTU(11),5400)
45715 WRITE(MSTU(11),6500)
45719 C...Only rewind when reading
45720 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
45724 C...Serious error catching
45725 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
45726 write(*,*) CHINL(1:80)
45728 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
45729 WRITE(*,*) CHINL(1:72)
45731 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
45732 WRITE(*,*) CHINL(1:80)
45734 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
45735 WRITE(*,*) CHINL(1:80)
45736 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
45738 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
45739 WRITE(*,*) CHINL(1:80)
45745 C...Formats for user information printout.
45746 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
45747 & ,'INTERFACE',1x,17('*')/1x,'*',2x
45748 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
45749 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
45750 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
45751 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
45752 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
45753 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
45754 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45755 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45756 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
45757 & ,'----------------')
45758 5400 FORMAT(1x,'*',1x,A)
45759 5500 FORMAT(1x,'*',1x,A,':')
45760 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45761 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45762 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
45763 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
45764 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45765 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
45766 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
45767 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45768 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45769 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45770 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45771 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
45772 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45773 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45774 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45775 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45776 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45777 & ,1x,F6.3,1x),'|')
45778 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45779 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45780 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45781 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45782 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45783 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45784 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45785 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45786 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45787 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45788 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45789 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45790 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
45791 & ,'A_tau = ',F8.2)
45792 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
45794 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
45796 C...Format to use for comments
45797 7000 FORMAT('# ',A)
45798 C...Format to use for block statements
45799 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
45800 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
45802 7110 FORMAT(1x,I4,1x,I4,3x,'#')
45803 C...Non-Indexed Double
45804 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
45806 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
45807 C...Long Indexed Double (PDG + double)
45808 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
45809 C...Indexed Char(12)
45810 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
45812 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
45814 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
45815 C...Write Decay Table
45816 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
45817 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
45823 C*********************************************************************
45826 C...Uses approximate analytical formulae to determine the full set of
45827 C...MSSM parameters from SUGRA input.
45828 C...See M. Drees and S.P. Martin, hep-ph/9504124
45832 C...Double precision and integer declarations.
45833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45834 IMPLICIT INTEGER(I-N)
45835 INTEGER PYK,PYCHGE,PYCOMP
45836 C...Parameter statement to help give large particle numbers.
45837 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45838 &KEXCIT=4000000,KDIMEN=5000000)
45840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45842 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45843 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
45845 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
45846 &' not intended for serious physics studies'
45859 C...Temporary sign change for AT. Others unchanged.
45863 SINB=TANB/SQRT(TANB**2+1D0)
45866 DTERM=XMZ2*COS(2D0*BETA)
45867 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
45868 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
45871 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
45872 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
45873 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
45874 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
45876 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
45877 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
45878 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
45879 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
45881 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
45882 IF(XARG.LT.0D0) THEN
45883 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45884 & ' FROM THE SUM RULE. '
45885 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45891 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
45892 PMAS(PYCOMP(KSUSY2+I),1)=XMER
45893 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45894 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45896 RMT=PYMRUN(6,PMAS(6,1)**2)
45897 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
45898 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
45899 RMB=PYMRUN(5,PMAS(6,1)**2)
45900 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
45901 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
45902 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
45903 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
45906 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
45907 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
45908 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
45909 XMU=SIGN(SQRT(XMU2),RMSS(4))
45911 IF(XMA2.GT.0D0) THEN
45912 RMSS(19)=SQRT(XMA2)
45914 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
45917 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
45918 IF(ARG.GT.0D0) THEN
45921 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
45924 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
45925 IF(ARG.GT.0D0) THEN
45928 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
45931 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
45932 IF(ARG.GT.0D0) THEN
45935 RMSS(10)=-SQRT(-ARG)
45937 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
45938 IF(ARG.GT.0D0) THEN
45941 RMSS(12)=-SQRT(-ARG)
45943 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
45944 IF(ARG.GT.0D0) THEN
45947 RMSS(11)=-SQRT(-ARG)
45953 C*********************************************************************
45956 C...Interface to ISASUSY version 7.71.
45957 C...Warning: this interface should not be used with earlier versions
45958 C...of ISASUSY, since common block incompatibilities may then arise.
45959 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
45960 C...Then converts to Gunion-Haber conventions.
45963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45965 INTEGER PYK,PYCHGE,PYCOMP
45966 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45967 &KEXCIT=4000000,KDIMEN=5000000)
45971 PARAMETER (DOC='01 May 2006')
45973 C...ISASUGRA Input:
45974 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
45975 C...XISAIN contains the MSSMi inputs in natural order.
45976 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
45978 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
45980 C...ISASUGRA Output
45981 CHARACTER*40 ISAVER,VISAJE
45983 COMMON /SSPAR/ SUPER(72)
45984 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
45985 $FBGUT,FTAGUT,FNGUT
45986 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
45987 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45988 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45989 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
45990 $VUMT,VDMT,ASMTP,ASMSS,M3Q
45991 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45992 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45993 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
45994 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
45996 SAVE /SUGMG/,/SSPAR/
45997 C SUPER: Filled by ISASUGRA.
45998 C SUPER(1) = mass of ~g
45999 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46000 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46001 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46003 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46004 C SUPER(29) = Higgsino mass = - mu
46005 C SUPER(30) = ratio v2/v1 of vev's
46006 C SUPER(31:34) = Signed neutralino masses
46007 C SUPER(35:50) = Neutralino mixing matrix
46008 C SUPER(51:52) = Signed chargino masses
46009 C SUPER(53:54) = Chargino left, right mixing angles
46010 C SUPER(55:58) = mass of h0, H0, A0, H+
46011 C SUPER(59) = Higgs mixing angle alpha
46012 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46013 C SUPER(66) = Gravitino mass
46014 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46015 C SUPER(70) = b-Yukawa at mA scale (not used)
46016 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46017 C GSS: Filled by ISASUGRA
46018 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46019 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46020 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46021 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46022 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46023 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46024 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46025 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46026 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46027 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46028 C GSS(31) = log(vuq)
46029 C MSS: Filled by ISASUGRA
46030 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46031 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46032 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46033 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46034 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46035 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46036 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46037 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46038 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46039 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46040 C MSS(31) = ha0 MSS(32) = h+
46041 C Unification, filled by ISASUGRA if applicable.
46042 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46044 C...SPYTHIA Input/Output
46046 DOUBLE PRECISION RMSS
46047 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46048 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46049 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46050 C...SLHA Input/Output
46051 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46052 & AU(3,3),AD(3,3),AE(3,3)
46053 C...PYTHIA common blocks
46054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46055 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46056 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46058 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
46059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46062 CHARACTER*20 CHMOD(5)
46065 COMMON /SUGNU/ XNUSUG(18)
46069 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
46070 & 'truly unified SUGRA', 'non-minimal GMSB'/
46072 C...Start by checking for incompatibilities/inconsistencies:
46074 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
46075 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
46076 & ,' option not used by PYSUGI'
46079 C...ISAJET works with REAL numbers.
46080 MZERO=REAL(RMSS(8))
46082 AZERO=REAL(RMSS(16))
46084 SGNMU=REAL(RMSS(4))
46085 MTOP=REAL(PMAS(6,1))
46087 IF (IMSS(1).EQ.12) THEN
46090 ELSEIF(IMSS(1).EQ.13) THEN
46091 C...Read from isajet par file in IMSS(20)
46093 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46095 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46098 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
46099 CMrenna change to allow any susy model
46100 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
46101 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
46102 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
46103 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
46104 & ' gauge couplings:'
46105 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
46107 IF (IMODEL.EQ.4) THEN
46111 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
46112 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46113 & //' sgn(mu), M_t:'
46114 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
46115 IF (IMODEL.EQ.3) THEN
46117 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46118 & //' 0 to continue:'
46119 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
46120 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
46121 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
46122 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
46123 & //' generation masses'
46125 & ' NUSUG5 = GUT scale 3rd generation masses'
46127 IF (INUSUG.EQ.0) THEN
46129 ELSEIF (INUSUG.EQ.1) THEN
46130 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
46131 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
46132 IF (XNUSUG(3).LE.0.) THEN
46133 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
46136 ELSEIF (INUSUG.EQ.2) THEN
46137 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
46138 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
46139 ELSEIF (INUSUG.EQ.3) THEN
46140 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
46141 READ(LFN,*) XNUSUG(7),XNUSUG(8)
46142 ELSEIF (INUSUG.EQ.4) THEN
46143 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
46144 & //' M(ur), M(el), M(er):'
46145 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
46146 & XNUSUG(10),XNUSUG(9)
46147 ELSEIF (INUSUG.EQ.5) THEN
46148 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
46149 & //' M(Ll), M(Lr):'
46150 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
46151 & XNUSUG(15),XNUSUG(14)
46155 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
46157 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
46158 & ,' sgn(mu), M_t, C_gv:'
46159 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
46162 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
46164 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
46165 IF (IMODEL.EQ.5) THEN
46167 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
46168 & ,' masses at M_mes'
46169 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
46170 & ,' shifts at M_mes'
46171 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
46173 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
46175 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
46177 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
46178 $ XGMIN(13),XGMIN(14)
46181 WRITE(MSTU(11),*) 'Invalid model choice.'
46189 C TANB=REAL(RMSS(5))
46190 C SGNMU=REAL(RMSS(4))
46193 C...Initialize MSSM parameter array
46194 130 DO 140 IPAR=1,72
46198 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
46199 C...Check whether ISASUSY thought the model was OK.
46200 IF (NOGOOD.NE.0) THEN
46201 IF (NOGOOD.EQ.1) CALL PYERRM(26
46202 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
46203 IF (NOGOOD.EQ.2) CALL PYERRM(26
46204 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
46205 IF (NOGOOD.EQ.3) CALL PYERRM(26
46206 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
46207 IF (NOGOOD.EQ.4) CALL PYERRM(26
46208 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
46209 IF (NOGOOD.EQ.7) CALL PYERRM(26
46210 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
46211 IF (NOGOOD.EQ.8) CALL PYERRM(26
46212 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
46213 C...Give warning, but don't stop, if LSP not ~chi_10.
46214 IF (NOGOOD.EQ.5) CALL PYERRM(16
46215 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
46217 C...Warn about possible GUT scale tachyons.
46218 IF (ITACHY.NE.0) CALL PYERRM(16,
46219 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
46220 C...Finalize spectrum (last iteration)
46221 C...(Thanks to A. Raklev for pointing this out.)
46222 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
46223 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
46224 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
46225 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
46226 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
46227 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
46231 RMSS(1)=dble(GSS(7))
46232 RMSS(2)=dble(GSS(8))
46233 RMSS(3)=dble(GSS(9))
46234 RMSOFT(1)=dble(GSS(7))
46235 RMSOFT(2)=dble(GSS(8))
46236 RMSOFT(3)=dble(GSS(9))
46237 C...Mu = - Higgsino mass.
46240 C...Slepton and squark masses. 2 first generations.
46241 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
46242 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
46243 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
46244 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
46245 C...Third generation.
46246 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
46251 C...SLHA: store exact soft spectrum in RMSOFT
46252 RMSOFT(31)=SUPER(18)
46253 RMSOFT(32)=SUPER(20)
46254 RMSOFT(33)=SUPER(22)
46255 RMSOFT(34)=SUPER(19)
46256 RMSOFT(35)=SUPER(21)
46257 RMSOFT(36)=SUPER(23)
46258 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
46259 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
46260 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
46261 RMSOFT(44)=SUPER(3)
46262 RMSOFT(45)=SUPER(9)
46263 RMSOFT(46)=SUPER(15)
46264 RMSOFT(47)=SUPER(5)
46265 RMSOFT(48)=SUPER(7)
46266 RMSOFT(49)=SUPER(11)
46268 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
46275 C...SLHA trilinears
46286 C...Higgs mixing angle alpha (Gunion-Haber convention).
46287 RMSS(18)=-SUPER(59)
46290 C...GUT scale coupling
46292 C...Gravitino mass (for future compatibility)
46293 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
46295 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
46297 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
46298 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
46299 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
46300 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
46302 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
46303 C...Squarks and Sleptons.
46306 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
46307 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
46308 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
46309 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
46310 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
46311 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
46312 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
46313 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
46314 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
46316 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
46317 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
46318 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
46320 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
46321 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
46322 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
46323 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
46324 C...Signed masses (extra minus from going to G-H convention).
46330 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
46331 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
46332 C...Signed masses (extra minus from going to G-H convention).
46336 C... Neutralino Mixing.
46338 ZMIX(IN,1)= SUPER(38+4*(IN-1))
46339 ZMIX(IN,2)= SUPER(37+4*(IN-1))
46340 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
46341 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
46343 C...Chargino Mixing (PYTHIA same angle as HERWIG).
46346 IF (SUPER(53).GT.0) THX=-1D0
46347 IF (SUPER(54).GT.0) THY=-1D0
46348 UMIX(1,1) = -SIN(SUPER(53))
46349 UMIX(1,2) = -COS(SUPER(53))
46350 UMIX(2,1) = -THX*COS(SUPER(53))
46351 UMIX(2,2) = THX*SIN(SUPER(53))
46352 VMIX(1,1) = -SIN(SUPER(54))
46353 VMIX(1,2) = -COS(SUPER(54))
46354 VMIX(2,1) = -THY*COS(SUPER(54))
46355 VMIX(2,2) = THY*SIN(SUPER(54))
46356 C...Sfermion mixing (PYTHIA same angle as ISAJET)
46357 SFMIX(5,1)=COS(SUPER(63))
46358 SFMIX(5,2)=SIN(SUPER(63))
46359 SFMIX(5,3)=-SIN(SUPER(63))
46360 SFMIX(5,4)=COS(SUPER(63))
46361 SFMIX(6,1)=COS(SUPER(61))
46362 SFMIX(6,2)=SIN(SUPER(61))
46363 SFMIX(6,3)=-SIN(SUPER(61))
46364 SFMIX(6,4)=COS(SUPER(61))
46365 SFMIX(15,1)=COS(SUPER(65))
46366 SFMIX(15,2)=SIN(SUPER(65))
46367 SFMIX(15,3)=-SIN(SUPER(65))
46368 SFMIX(15,4)=COS(SUPER(65))
46370 IF (MSTP(122).NE.0) THEN
46371 C...Print a few lines to make the user know what's happening
46373 WRITE(MSTU(11),5000) DOC, ISAVER
46374 WRITE(MSTU(11),5100)
46375 IF (IMODEL.EQ.1) THEN
46376 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
46378 WRITE(MSTU(11),5300)
46380 WRITE(MSTU(11),5500) 'Pole masses'
46381 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
46382 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
46383 & ,(SUPER(IP),IP=19,25,2)
46384 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
46386 WRITE(MSTU(11),5400)
46387 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
46388 WRITE(MSTU(11),5400)
46389 WRITE(MSTU(11),5500) 'EW scale mixing structure'
46390 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46391 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46392 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46393 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46394 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46395 & ),(SFMIX(15,J),J=3,4)
46396 WRITE(MSTU(11),5400)
46397 WRITE(MSTU(11),6450) RMSS(18)
46398 WRITE(MSTU(11),5400)
46399 WRITE(MSTU(11),5500) 'Couplings'
46400 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
46401 WRITE(MSTU(11),5400)
46404 C...Call FeynHiggs to improve Higgs sector if requested
46405 IF (IMSS(4).EQ.3) THEN
46406 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
46407 & ' (PYSUGI:) Now calling FeynHiggs.'
46409 IF (IERR.EQ.0) THEN
46411 IF (MSTP(122).NE.0) THEN
46412 WRITE(MSTU(11),5400)
46413 WRITE(MSTU(11),5500)
46414 & 'Corrected Higgs masses and mixing'
46415 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
46417 WRITE(MSTU(11),6450) RMSS(18)
46418 WRITE(MSTU(11),5400)
46423 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
46425 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
46426 C...output by ISASUSY.
46427 IMSS(4)=MAX(2,IMSS(4))
46429 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
46430 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
46431 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
46432 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
46433 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46434 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46435 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
46436 & ,'----------------')
46437 5400 FORMAT(1x,'*',1x,A)
46438 5500 FORMAT(1x,'*',1x,A,':')
46439 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46440 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46441 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
46442 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
46443 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
46445 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
46446 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
46447 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
46449 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46450 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46451 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46452 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46453 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
46454 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46455 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
46456 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46457 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46458 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46459 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46460 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46461 & ,1x,F6.3,1x),'|')
46462 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46463 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46464 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46465 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46466 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46467 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46468 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46469 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46470 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46471 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46472 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46473 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46474 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
46475 & ,4x,'Alpha_GUT = ',F8.2)
46476 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
46477 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
46482 C*********************************************************************
46485 C...Interface to FeynHiggs for MSSM Higgs sector.
46486 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
46489 SUBROUTINE PYFEYN(IERR)
46491 C...Double precision and integer declarations.
46492 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46493 IMPLICIT INTEGER(I-N)
46494 INTEGER PYK,PYCHGE,PYCOMP
46496 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46497 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46499 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46500 C...FeynHiggs variables
46501 DOUBLE PRECISION RMHIGG(4)
46502 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
46503 DOUBLE COMPLEX DMU,
46504 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46506 C...SLHA Common Block
46507 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46508 & AU(3,3),AD(3,3),AE(3,3)
46509 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
46512 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
46513 IF (IERR.NE.0) THEN
46514 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
46515 & //'Will not use FeynHiggs for this run.')
46553 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
46554 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
46555 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
46556 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
46557 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46558 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
46559 IF (IERR.NE.0) THEN
46560 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
46561 & //' Will not use FeynHiggs for this run.')
46564 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
46566 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
46567 IF (IERR.NE.0) THEN
46568 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
46569 & 'GSCORR. Will not use FeynHiggs for this run.')
46572 ALPHA = ASIN(DBLE(SAEFF))
46574 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
46575 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46576 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
46577 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
46579 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
46580 & 1.15D0*PMAS(25,1)) THEN
46581 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46582 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
46583 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
46586 PMAS(25,1)=RMHIGG(1)
46587 PMAS(35,1)=RMHIGG(2)
46588 PMAS(36,1)=RMHIGG(3)
46589 PMAS(37,1)=RMHIGG(4)
46594 C*********************************************************************
46597 C...Determines the running mass of Squarks.
46599 FUNCTION PYRNMQ(ID,DTERM)
46601 C...Double precision and integer declarations.
46602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46603 IMPLICIT INTEGER(I-N)
46604 INTEGER PYK,PYCHGE,PYCOMP
46606 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46609 C...Local variables.
46610 DOUBLE PRECISION PI,R
46611 DOUBLE PRECISION TOL
46612 DOUBLE PRECISION CI(3)
46614 DOUBLE PRECISION PYALPS
46616 DATA PI,R/3.141592654D0,.61803399D0/
46617 DATA CI/0.47D0,0.07D0,0.02D0/
46621 AG=(0.71D0)**2/4D0/PI
46628 AS=PYALPS(XM02+6D0*XMG2)
46629 CG=8D0/9D0*((AS/AG)**2-1D0)
46630 BX=XM02+(CA+CG)*XMG2+DTERM
46631 AX=MIN(50D0**2,0.5D0*BX)
46632 CX=MAX(2000D0**2,2D0*BX)
46636 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46644 CG=8D0/9D0*((AS1/AG)**2-1D0)
46645 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46647 CG=8D0/9D0*((AS2/AG)**2-1D0)
46648 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46649 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46656 CG=8D0/9D0*((AS2/AG)**2-1D0)
46657 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46664 CG=8D0/9D0*((AS1/AG)**2-1D0)
46665 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46680 C*********************************************************************
46683 C...Calculates the mass eigenstates of the third generation sfermions.
46684 C...Created: 5-31-96
46688 C...Double precision and integer declarations.
46689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46690 IMPLICIT INTEGER(I-N)
46691 INTEGER PYK,PYCHGE,PYCOMP
46692 C...Parameter statement to help give large particle numbers.
46693 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46694 &KEXCIT=4000000,KDIMEN=5000000)
46696 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46697 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46698 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46699 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46700 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46701 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46703 C...Local variables.
46704 DOUBLE PRECISION BETA
46705 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
46706 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
46707 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
46708 DOUBLE PRECISION ATR,AMQR,AMQL
46709 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
46710 INTEGER IF,I,J,II,JJ,IT,L
46724 COS2B=COS(2D0*BETA)
46726 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
46736 XMQL2=CTT2*XM12+STT2*XM22
46737 XMQR2=STT2*XM12+CTT2*XM22
46738 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
46739 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46741 C......SUBTRACT OUT D-TERM AND FERMION MASS
46742 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
46743 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
46744 IF(XMQL2.GE.0D0) THEN
46745 RMSS(10)=SQRT(XMQL2)
46747 RMSS(10)=-SQRT(-XMQL2)
46749 IF(XMQR2.GE.0D0) THEN
46750 RMSS(12)=SQRT(XMQR2)
46752 RMSS(12)=-SQRT(-XMQR2)
46755 C SAME FOR BOTTOM SQUARK
46761 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
46762 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
46763 IF(ABS(CTT).GE..9999D0) THEN
46766 ELSEIF(ABS(CTT).LE.1D-4) THEN
46770 XM12=(XMQL2-STT2*XM22)/CTT2
46771 XMQR2=STT2*XM12+CTT2*XM22
46772 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46775 C......SUBTRACT OUT D-TERM AND FERMION MASS
46776 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
46777 IF(XMQR2.GE.0D0) THEN
46778 RMSS(11)=SQRT(XMQR2)
46780 RMSS(11)=-SQRT(-XMQR2)
46782 C SAME FOR TAU SLEPTON
46789 XMQL2=CTT2*XM12+STT2*XM22
46790 XMQR2=STT2*XM12+CTT2*XM22
46793 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46795 C......SUBTRACT OUT D-TERM AND FERMION MASS
46796 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
46797 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
46798 IF(XMQL2.GE.0D0) THEN
46799 RMSS(13)=SQRT(XMQL2)
46801 RMSS(13)=-SQRT(-XMQL2)
46803 IF(XMQR2.GE.0D0) THEN
46804 RMSS(14)=SQRT(XMQR2)
46806 RMSS(14)=-SQRT(-XMQR2)
46811 IF(AMQL.LT.0D0) THEN
46818 IF(AMQR.LT.0D0) THEN
46824 XMF=PYMRUN(IF,PMAS(6,1)**2)
46826 AM2(1,1)=XMQL2+XMF2
46827 AM2(2,2)=XMQR2+XMF2
46828 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
46831 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
46832 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
46833 AM2(1,2)=XMF*(ATR+XMU*TANB)
46834 ELSEIF(L.EQ.2) THEN
46835 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
46836 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
46837 AM2(1,2)=XMF*(ATR+XMU/TANB)
46838 ELSEIF(L.EQ.3) THEN
46839 IF(IMSS(8).EQ.1) THEN
46840 AM2(1,1)=RMSS(6)**2
46841 AM2(2,2)=RMSS(7)**2
46846 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
46847 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
46848 AM2(1,2)=XMF*(ATR+XMU*TANB)
46853 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
46854 IF(DETM.LT.0D0) THEN
46855 WRITE(MSTU(11),*) ID2(L),DETM,AM2
46856 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
46858 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
46859 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
46863 IF(XMF22-XMF12.GT.0D0) THEN
46864 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
46866 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
46867 & AM2(1,2)/(XMF22-XMF12))
46883 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
46889 IF(DI(1,1).GT.DI(2,2)) THEN
46890 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
46891 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
46892 WRITE(MSTU(11),*) AM2
46893 WRITE(MSTU(11),*) DI
46894 WRITE(MSTU(11),*) RT
46905 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
46906 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46907 & ' OFF DIAGONAL ELEMENTS '
46908 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
46909 WRITE(MSTU(11),*) DI
46910 WRITE(MSTU(11),*) ' ROTATION = ',RT
46912 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
46913 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46914 & ' NEGATIVE MASSES '
46917 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
46918 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
46919 SFMIX(IF,1)=RT(1,1)
46920 SFMIX(IF,2)=RT(1,2)
46921 SFMIX(IF,3)=RT(2,1)
46922 SFMIX(IF,4)=RT(2,2)
46925 C.....TAU SNEUTRINO MASS...L=3
46927 XARG=AM2(1,1)+XMW2*COS2B
46928 IF(XARG.LT.0D0) THEN
46929 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
46930 & ' FROM THE SUM RULE. '
46931 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46934 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
46939 C*********************************************************************
46942 C...Finds the mass eigenstates and mixing matrices for neutralinos
46947 C...Double precision and integer declarations.
46948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46949 IMPLICIT INTEGER(I-N)
46951 C...Parameter statement to help give large particle numbers.
46952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46953 &KEXCIT=4000000,KDIMEN=5000000)
46955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46956 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46957 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46958 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46959 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46960 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46962 C...Local variables.
46963 DOUBLE PRECISION XMW,XMZ,XM(4)
46964 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
46965 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
46966 DOUBLE PRECISION COSW,SINW
46967 DOUBLE PRECISION XMU
46968 DOUBLE PRECISION TANB,COSB,SINB
46969 DOUBLE PRECISION XM1,XM2,XM3,BETA
46970 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
46971 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
46972 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
46973 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
46974 DOUBLE PRECISION PYALPS,PYALEM
46975 DOUBLE PRECISION PYRNM3
46976 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
46977 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
46978 DATA KFNCHI/1000022,1000023,1000025,1000035/
46981 IF(IMSS(1).EQ.2) THEN
46984 C...M1, M2, AND M3 ARE INDEPENDENT
46989 ELSEIF(IOPT.GE.1) THEN
46993 A1=AEM/(1D0-PARU(102))
46996 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
46998 XM2=XM1*A2/A1*3D0/5D0
47000 ELSEIF(IOPT.EQ.3) THEN
47001 XM1=XM2*5D0/3D0*A1/A2
47006 IF(XM3.LE.0D0) THEN
47007 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47013 IF(IMSS(3).EQ.1) THEN
47014 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47019 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47020 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
47021 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
47027 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47028 RM2=PMAS(I,1)**2/XM3**2
47029 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
47030 IF(ARG.GE.0D0) THEN
47031 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
47033 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
47038 ELSEIF(X0.EQ.0D0) THEN
47042 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
47043 & 0.5D0*X0**2*LOG(AX0)
47044 BT=(-1D0-2D0*X0)/4D0
47049 ELSEIF(X1.EQ.0D0) THEN
47053 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
47054 & X1**2*LOG(AX1)+AT
47055 BT=(-1D0-2D0*X1)/4D0+BT
47059 X0=0.5D0*(1D0+RM2-RM1)
47060 Y0=-0.5D0*SQRT(-ARG)
47061 AMGX0=SQRT(X0**2+Y0**2)
47062 AM1X0=SQRT((1D0-X0)**2+Y0**2)
47063 ARGX0=ATAN2(-X0,-Y0)
47064 AR1X0=ATAN2(1D0-X0,Y0)
47069 ARGX1=ATAN2(-X1,-Y1)
47070 AR1X1=ATAN2(1D0-X1,Y1)
47071 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
47072 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
47073 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
47074 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
47075 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
47076 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
47081 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
47082 & /(2D0*PARU(2))*(15D0+AQ))
47085 C...NEUTRALINO MASSES
47091 XMZ=PMAS(23,1)/100D0
47092 XMW=PMAS(24,1)/100D0
47094 SINW=SQRT(PARU(102))
47095 COSW=SQRT(1D0-PARU(102))
47106 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47107 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47108 AR(1,1) = XM1*COS(RMSS(30))
47109 AI(1,1) = XM1*SIN(RMSS(30))
47110 AR(2,2) = XM2*COS(RMSS(31))
47111 AI(2,2) = XM2*SIN(RMSS(31))
47116 AR(1,3) = -XMZ*SINW*COSB
47118 AR(1,4) = XMZ*SINW*SINB
47120 AR(2,3) = XMZ*COSW*COSB
47122 AR(2,4) = -XMZ*COSW*SINB
47124 AR(3,4) = -XMU*COS(RMSS(33))
47125 AI(3,4) = -XMU*SIN(RMSS(33))
47126 AR(4,3) = -XMU*COS(RMSS(33))
47127 AI(4,3) = -XMU*SIN(RMSS(33))
47128 C CALL PYEIG4(AR,WR,ZR)
47129 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47130 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47131 & 'PROBLEM WITH PYEICG IN PYINOM ')
47139 IF(XM(K).LT.XM(J)) THEN
47157 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
47160 S=S+ZR(J,K)**2+ZI(J,K)**2
47163 ZMIX(I,J)=ZR(J,K)/SQRT(S)
47164 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
47165 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
47166 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
47170 C...CHARGINO MASSES
47171 C.....Find eigenvectors of X X^*
47180 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
47181 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
47182 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47183 &XMU*COS(RMSS(33))*SINB)
47184 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
47185 &XMU*SIN(RMSS(33))*SINB)
47186 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47187 &XMU*COS(RMSS(33))*SINB)
47188 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
47189 &XMU*SIN(RMSS(33))*SINB)
47190 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47191 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47192 & 'PROBLEM WITH PYEICG IN PYINOM ')
47195 IF(WR(2).LT.WR(1)) THEN
47203 SMW(I)=SQRT(WR(K))*100D0
47206 S=S+ZR(J,K)**2+ZI(J,K)**2
47209 UMIX(I,J)=ZR(J,K)/SQRT(S)
47210 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
47211 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
47212 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
47215 C...Force chargino mass > neutralino mass
47217 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
47218 CALL PYERRM(18,'(PYINOM:) '//
47219 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
47220 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
47223 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
47224 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
47226 C.....Find eigenvectors of X^* X
47237 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
47238 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
47239 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47240 &XMU*COS(RMSS(33))*COSB)
47241 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
47242 &XMU*SIN(RMSS(33))*COSB)
47243 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47244 &XMU*COS(RMSS(33))*COSB)
47245 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
47246 &XMU*SIN(RMSS(33))*COSB)
47247 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47248 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47249 & 'PROBLEM WITH PYEICG IN PYINOM ')
47252 IF(WR(2).LT.WR(1)) THEN
47262 S=S+ZR(J,K)**2+ZI(J,K)**2
47263 SIMAG=SIMAG+ZI(J,K)**2
47266 VMIX(I,J)=ZR(J,K)/SQRT(S)
47267 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
47268 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
47269 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
47273 C.....Simplify if no phases
47274 IF(SIMAG.LT.1D-6) THEN
47275 AR(1,1) = XM2*COS(RMSS(31))
47276 AR(2,2) = XMU*COS(RMSS(33))
47277 AR(1,2) = SQRT(2D0)*XMW*SINB
47278 AR(2,1) = SQRT(2D0)*XMW*COSB
47291 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
47296 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
47297 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
47298 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
47299 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
47300 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47301 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47302 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
47306 C.....Must deal with phases
47308 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
47309 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
47310 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
47311 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
47317 CAI(I,J)=CMPLX(0D0,0D0)
47325 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
47326 & CMPLX(VMIX(J,L),VMIXI(J,L))
47332 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
47333 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
47336 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47337 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47340 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47341 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47344 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47345 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47348 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47349 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47350 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47351 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47352 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
47353 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
47361 C*********************************************************************
47364 C...Calculates the running of M3, the SU(3) gluino mass parameter.
47366 FUNCTION PYRNM3(RGUT)
47368 C...Double precision and integer declarations.
47369 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47370 IMPLICIT INTEGER(I-N)
47371 INTEGER PYK,PYCHGE,PYCOMP
47373 C...Local variables.
47375 DOUBLE PRECISION TOL
47377 DOUBLE PRECISION PYALPS
47379 DATA R/0.61803399D0/
47383 BX=RGUT*PYALPS(RGUT**2)
47384 AX=MIN(50D0,BX*0.5D0)
47385 CX=MAX(2000D0,2D0*BX)
47389 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47397 F1=ABS(X1-RGUT*AS1)
47399 F2=ABS(X2-RGUT*AS2)
47400 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47407 F2=ABS(X2-RGUT*AS2)
47414 F1=ABS(X1-RGUT*AS1)
47429 C*********************************************************************
47432 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
47433 C...Specific application: mixing in neutralino sector.
47435 SUBROUTINE PYEIG4(A,W,Z)
47437 C...Double precision and integer declarations.
47438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47439 IMPLICIT INTEGER(I-N)
47440 INTEGER PYK,PYCHGE,PYCOMP
47442 C...Arrays: in call and local.
47443 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
47445 C...Coefficients of fourth-degree equation from matrix.
47446 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
47447 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
47451 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
47460 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
47461 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
47462 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
47463 B0=B0+(-1D0)**(I+1)*A(1,I)*(
47464 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
47465 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
47466 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
47469 C...Coefficients of third-degree equation needed for
47470 C...separation into two second-degree equations.
47471 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
47474 C0=-B1**2-B0*B3**2+4D0*B0*B2
47475 CQ=C1/3D0-C2**2/9D0
47476 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
47479 C...Cases with one or three real roots.
47480 IF(CQR.GE.0D0) THEN
47481 S1=(CR+SQRT(CQR))**(1D0/3D0)
47482 S2=(CR-SQRT(CQR))**(1D0/3D0)
47486 THE=ACOS(CR/SABS**3)/3D0
47491 C...Find and solve two second-degree equations.
47492 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
47493 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
47494 Q1=U/2D0+SQRT(U**2/4D0-B0)
47495 Q2=U/2D0-SQRT(U**2/4D0-B0)
47496 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
47501 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
47502 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
47503 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
47504 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
47506 C...Order eigenvalues in asceding mass.
47509 DO 130 I2=I1-1,1,-1
47510 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
47516 C...Find equation system for eigenvectors.
47519 D(J1,J1)=A(J1,J1)-W(I)
47526 C...Find largest element in matrix.
47530 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
47533 DAMAX=ABS(D(J1,J2))
47537 C...Subtract others by multiple of row selected above.
47539 DO 210 J3=JA+1,JA+3
47541 RL=D(J1,JB)/D(JA,JB)
47543 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
47544 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
47547 DAMAX=ABS(D(J1,J2))
47551 C...Do one more subtraction of a row.
47553 DO 230 J3=JC+1,JC+3
47555 IF(J1.EQ.JA) GOTO 230
47556 RL=D(J1,JD)/D(JC,JD)
47558 IF(J2.EQ.JB) GOTO 220
47559 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
47560 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
47562 DAMAX=ABS(D(J1,J2))
47566 C...Construct unnormalized eigenvector.
47568 JF2=JD+2-4*((JD+1)/4)
47569 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
47570 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
47573 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
47574 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
47577 C...Normalize and fill in final array.
47578 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
47579 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47588 C*********************************************************************
47591 C...Determines the Higgs boson mass spectrum using several inputs.
47593 SUBROUTINE PYHGGM(ALPHA)
47595 C...Double precision and integer declarations.
47596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47597 IMPLICIT INTEGER(I-N)
47598 INTEGER PYK,PYCHGE,PYCOMP
47599 C...Parameter statement to help give large particle numbers.
47600 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47601 &KEXCIT=4000000,KDIMEN=5000000)
47603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47606 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47607 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
47609 C...Local variables.
47610 DOUBLE PRECISION AT,AB,XMU,TANB
47611 DOUBLE PRECISION ALPHA
47613 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
47614 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
47615 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
47616 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
47619 IF(IHOPT.EQ.2) THEN
47635 DMC=PMAS(PYCOMP(KSUSY1+37),1)
47642 IF(IHOPT.EQ.0) THEN
47643 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47644 & DMHCH,DSA,DCA,DTANBA)
47645 ELSEIF(IHOPT.EQ.1) THEN
47646 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47647 & DMHCH,DSA,DCA,DTANBA)
47648 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
47649 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
47650 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
47656 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
47657 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
47658 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
47659 & PMAS(PYCOMP(1000006),1),DSTOP2
47661 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
47662 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
47663 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
47664 & PMAS(PYCOMP(2000006),1),DSTOP1
47666 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
47667 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
47668 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
47669 & PMAS(PYCOMP(1000005),1),DSBOT2
47671 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
47672 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
47673 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
47674 & PMAS(PYCOMP(2000005),1),DSBOT1
47677 ELSEIF (IHOPT.EQ.3) THEN
47678 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
47679 C...Currently only available for SLHA spectrum read-in.
47680 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
47681 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
47682 & //' spectrum, change IMSS(1) or IMSS(4) option.')
47698 C*********************************************************************
47701 C...This routine computes the renormalization group improved
47702 C...values of Higgs masses and couplings in the MSSM.
47704 C...Program based on the work by M. Carena, J.R. Espinosa,
47705 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
47707 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
47708 C...All masses in GeV units. MA is the CP-odd Higgs mass,
47709 C...MTOP is the physical top mass, MQ and MUR are the soft
47710 C...supersymmetry breaking mass parameters of left handed
47711 C...and right handed stops respectively, AU and AD are the
47712 C...stop and sbottom trilinear soft breaking terms,
47713 C...respectively, and MU is the supersymmetric
47714 C...Higgs mass parameter. We use the conventions from
47715 C...the physics report of Haber and Kane: left right
47716 C...stop mixing term proportional to (AU - MU/TANB)
47717 C...We use as input TANB defined at the scale MTOP
47719 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
47720 C...where MH and HM are the lightest and heaviest CP-even
47721 C...Higgs masses, MHCH is the charged Higgs mass and
47722 C...ALPHA is the Higgs mixing angle
47723 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
47725 C...Range of validity:
47726 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
47727 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
47728 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
47729 C...are the sbottom mass eigenvalues, respectively. This
47730 C...range automatically excludes the existence of tachyons.
47731 C...For the charged Higgs mass computation, the method is
47733 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
47734 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
47735 C...where M_SUSY**2 is the average of the squared stop mass
47736 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
47737 C...masses have been assumed to be of order of the stop ones
47738 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
47740 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
47741 &XMHCH,SA,CA,TANBA)
47743 C...Double precision and integer declarations.
47744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47745 IMPLICIT INTEGER(I-N)
47746 INTEGER PYK,PYCHGE,PYCOMP
47747 C...Parameter statement to help give large particle numbers.
47748 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47749 &KEXCIT=4000000,KDIMEN=5000000)
47751 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47752 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47753 COMMON/PYHTRI/HHH(7)
47754 SAVE /PYDAT1/,/PYDAT2/
47756 C...Local variables.
47757 DOUBLE PRECISION PYALEM,PYALPS
47758 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
47759 DOUBLE PRECISION XMHCH,SA,CA
47760 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
47761 DOUBLE PRECISION Q02
47762 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
47763 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
47764 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
47765 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
47766 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
47767 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
47768 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
47769 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
47774 ALP1=AEM/(1D0-PARU(102))
47787 C...MBOTTOM(MTOP) = 3. GEV
47788 XMB = PYMRUN(5,XMTOP**2)
47789 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
47790 &LOG(XMTOP**2/XMZ**2))
47792 C...RMTOP= RUNNING TOP QUARK MASS
47793 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
47794 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
47795 T = LOG(XMS**2/XMTOP**2)
47796 SINB = TANB/((1D0 + TANB**2)**0.5D0)
47798 C...IF(MA.LE.XMTOP) TANBA = TANBT
47800 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
47801 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
47802 &LOG(XMA**2/XMTOP**2))
47804 SINBT = TANBT/SQRT(1D0 + TANBT**2)
47805 COSBT = 1D0/SQRT(1D0 + TANBT**2)
47806 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
47807 G1 = SQRT(ALP1*4D0*PI)
47808 G2 = SQRT(ALP2*4D0*PI)
47809 G3 = SQRT(ALP3*4D0*PI)
47824 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
47825 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
47826 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
47827 &+ 3D0*(AU + AD)**2/XMS2)/6D0
47828 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
47829 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
47830 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
47831 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
47832 &- 16D0*G3**2) *T/16D0/PI2)
47833 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
47834 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
47835 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
47836 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
47837 &- 16D0*G3**2) *T/16D0/PI2)
47838 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47839 &(HU2 + HD2)*T/16D0/PI2)
47840 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47841 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47842 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47843 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
47844 &- 16D0*G3**2) *T/16D0/PI2)
47845 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47846 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
47847 &- 16D0*G3**2) *T/16D0/PI2)
47848 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
47849 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47850 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47851 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47853 &(1+ (6D0*HU2 -2D0* HD2
47854 &- 16D0*G3**2) *T/16D0/PI2)
47855 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47857 &(1+ (6D0*HD2 -2D0* HU2/2D0
47858 &- 16D0*G3**2) *T/16D0/PI2)
47859 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
47860 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
47861 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
47862 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
47863 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
47864 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47865 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
47866 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47867 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
47868 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47869 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
47870 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47878 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
47879 &2D0* XLAM6*SINBT*COSBT
47880 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
47882 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
47884 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
47885 &2D0* XLAM6* COSBT*SINBT
47886 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47887 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
47888 &((XLAM1* COSBT**2 +2D0*
47889 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
47890 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
47892 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
47893 &+ XLAM4) + XLAM6*COSBT**2
47894 &+ XLAM7* SINBT**2))
47896 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
47897 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
47900 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
47901 XMHCH = SQRT(XMHCH2)
47903 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47904 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47905 &XLAM6* COSBT*SINBT
47906 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47907 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47908 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
47909 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
47911 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
47912 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
47913 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
47914 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
47915 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47916 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47917 &XLAM6* COSBT*SINBT
47918 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47919 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47920 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
47930 C*********************************************************************
47933 C...This subroutine computes the CP-even higgs and CP-odd pole
47934 c...Higgs masses and mixing angles.
47936 C...Program based on the work by M. Carena, M. Quiros
47937 C...and C.E.M. Wagner, "Effective potential methods and
47938 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
47940 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
47942 C...where MCHI is the largest chargino mass, MA is the running
47943 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
47944 C...expectaion values at the scale MTOP, MQ is the third generation
47945 C...left handed squark mass parameter, MUR is the third generation
47946 C...right handed stop mass parameter, MDR is the third generation
47947 C...right handed sbottom mass parameter, MTOP is the pole top quark
47948 C...mass; AT,AB are the soft supersymmetry breaking trilinear
47949 C...couplings of the stop and sbottoms, respectively, and MU is the
47950 C...supersymmetric mass parameter
47952 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
47953 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
47954 C...masses are given, what makes the running of the program
47955 c...much faster and it is quite generally a good approximation
47956 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
47957 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
47958 c...and if IHIGGS=3, then h,H,A polarizations are computed
47960 C...Output: MH and MHP which are the lightest CP-even Higgs running
47961 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
47962 C...Higgs running and pole masses, repectively; SA and CA are the
47963 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
47964 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
47965 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
47966 C...the value of TANB at the CP-odd Higgs mass scale
47968 C...This subroutine makes use of CERN library subroutine
47969 C...integration package, which makes the computation of the
47970 C...pole Higgs masses somewhat faster. We thank P. Janot for this
47971 C...improvement. Those who are not able to call the CERN
47972 C...libraries, please use the subroutine SUBHPOLE2.F, which
47973 C...although somewhat slower, gives identical results
47975 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
47976 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
47978 C...Double precision and integer declarations.
47979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47980 IMPLICIT INTEGER(I-N)
47983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47985 INTEGER PYK,PYCHGE,PYCOMP
47987 C...Local variables.
47988 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
47989 &SSBOT2(2),B(2,2),COUPB(2,2),
47990 &HCOUPT(2,2),HCOUPB(2,2),
47991 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48000 RXMT=PYMRUN(6,XMT**2)
48001 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48002 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48004 SINB = TANB/(TANB**2+1D0)**0.5D0
48005 COSB = 1D0/(TANB**2+1D0)**0.5D0
48006 COS2B = SINB**2 - COSB**2
48007 SINBPA = SINB*CA + COSB*SA
48008 COSBPA = COSB*CA - SINB*SA
48009 RMBOT = PYMRUN(5,XMT**2)
48012 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48014 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48015 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48016 IF(XMST11.LT.0D0) GOTO 500
48017 IF(XMST22.LT.0D0) GOTO 500
48018 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
48019 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
48020 IF(XMSB11.LT.0D0) GOTO 500
48021 IF(XMSB22.LT.0D0) GOTO 500
48022 C WMST11 = RXMT**2 + XMQ2
48023 C WMST22 = RXMT**2 + XMUR2
48024 XMST12 = RXMT*(AT - XMU/TANB)
48025 XMSB12 = RMBOT*(AB - XMU*TANB)
48027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48028 C...STOP EIGENVALUES CALCULATION
48029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48031 STOP12 = 0.5D0*(XMST11+XMST22) +
48032 &0.5D0*((XMST11+XMST22)**2 -
48033 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
48034 STOP22 = 0.5D0*(XMST11+XMST22) -
48035 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
48036 &XMST12**2))**0.5D0
48038 IF(STOP22.LT.0D0) GOTO 500
48041 STOP1 = STOP12**0.5D0
48042 STOP2 = STOP22**0.5D0
48046 IF(XMST12.EQ.0D0) XST11 = 1D0
48047 IF(XMST12.EQ.0D0) XST12 = 0D0
48048 IF(XMST12.EQ.0D0) XST21 = 0D0
48049 IF(XMST12.EQ.0D0) XST22 = 1D0
48051 IF(XMST12.EQ.0D0) GOTO 110
48053 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48054 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48055 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48056 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48063 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
48064 &0.5D0*((XMSB11+XMSB22)**2 -
48065 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
48066 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
48067 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
48068 &XMSB12**2))**0.5D0
48069 IF(SBOT22.LT.0D0) GOTO 500
48070 SBOT1 = SBOT12**0.5D0
48071 SBOT2 = SBOT22**0.5D0
48076 IF(XMSB12.EQ.0D0) XSB11 = 1D0
48077 IF(XMSB12.EQ.0D0) XSB12 = 0D0
48078 IF(XMSB12.EQ.0D0) XSB21 = 0D0
48079 IF(XMSB12.EQ.0D0) XSB22 = 1D0
48081 IF(XMSB12.EQ.0D0) GOTO 130
48083 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48084 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48085 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48086 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48099 C...STARTING OF LIGHT HIGGS
48100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48102 IF(IHIGGS.EQ.0) GOTO 490
48107 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
48108 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48109 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
48110 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
48119 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
48120 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48121 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
48122 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
48130 180 ITER = ITER + 1
48133 PR(I3)=PRUN+(I3-2)*EPS/2
48138 POLT = POLT + COUPT(I,J)**2*3D0*
48139 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48146 POLB = POLB + COUPB(I,J)**2*3D0*
48147 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48154 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48156 & (-2D0*XMT**2+0.5D0*P2)*
48157 & PYFINT(P2,XMT2,XMT2)
48159 POL = POLT + POLB + POLTT
48160 POLAR(I3) = P2 - XMH**2 - POL
48162 DERIV = (POLAR(3)-POLAR(1))/EPS
48163 DRUN = - POLAR(2)/DERIV
48166 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
48172 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48173 C...END OF LIGHT HIGGS
48174 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48176 250 IF(IHIGGS.EQ.1) GOTO 490
48178 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48179 C... STARTING OF HEAVY HIGGS
48180 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48185 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
48186 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48187 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
48188 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
48196 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
48197 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48198 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
48199 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
48208 300 ITER = ITER + 1
48210 PR(I3)=PRUN+(I3-2)*EPS/2
48216 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
48217 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48224 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
48225 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48233 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48235 & (-2D0*XMT**2+0.5D0*HP2)*
48236 & PYFINT(HP2,XMT2,XMT2)
48238 HPOL = HPOLT + HPOLB + HPOLTT
48239 POLAR(I3) =HP2-HM**2-HPOL
48241 DERIV = (POLAR(3)-POLAR(1))/EPS
48242 DRUN = - POLAR(2)/DERIV
48245 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
48253 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48254 C... END OF HEAVY HIGGS
48255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48257 IF(IHIGGS.EQ.2) GOTO 490
48259 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48260 C...BEGINNING OF PSEUDOSCALAR HIGGS
48261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48266 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
48267 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
48273 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
48274 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
48281 420 ITER = ITER + 1
48283 PR(I3)=PRUN+(I3-2)*EPS/2
48288 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
48289 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48295 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
48296 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48302 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48303 & COSB**2/SINB**2 *
48305 & PYFINT(AP2,XMT2,XMT2)
48306 APOL = APOLT + APOLB + APOLTT
48307 POLAR(I3) = AP2 - XMA**2 -APOL
48309 DERIV = (POLAR(3)-POLAR(1))/EPS
48310 DRUN = - POLAR(2)/DERIV
48313 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
48319 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48320 C...END OF PSEUDOSCALAR HIGGS
48321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48323 IF(IHIGGS.EQ.3) GOTO 490
48328 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
48329 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
48330 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
48331 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
48335 C*********************************************************************
48338 C...Auxiliary to PYPOLE.
48340 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
48341 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
48342 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
48343 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
48346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48357 C MBOTTOM(MTOP) = 3. GEV
48358 MB = PYMRUN(5,MTOP**2)
48359 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
48360 *LOG(MTOP**2/MZ**2))
48361 C RMTOP= RUNNING TOP QUARK MASS
48362 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48363 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
48364 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
48365 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
48366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48368 C NEW DEFINITION, TGLU.
48370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48371 TGLU = LOG(MGLU**2/MTOP**2)
48372 SINB = TANB/DSQRT(1D0 + TANB**2)
48375 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
48376 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
48377 *LOG(MA**2/MTOP**2))
48378 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
48379 SINB = TANBT/SQRT(1D0 + TANBT**2)
48380 COSB = 1D0/DSQRT(1D0 + TANBT**2)
48381 G1 = SQRT(ALPHA1*4D0*PI)
48382 G2 = SQRT(ALPHA2*4D0*PI)
48383 G3 = SQRT(ALPHA3*4D0*PI)
48386 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
48387 *SBOT1,SBOT2,DELTAMT,DELTAMB)
48388 IF(MQ.GT.MUR) TP = TQ - TU
48389 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
48390 IF(MQ.GT.MUR) TDP = TU
48391 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
48392 IF(MQ.GT.MD) TPD = TQ - TD
48393 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
48394 IF(MQ.GT.MD) TDPD = TD
48395 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
48397 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
48398 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
48399 * HD**2*(G1**2/3D0+G2**2)*TPD
48401 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
48402 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
48403 * HU**2*(-G1**2/3D0+G2**2)*TP
48405 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48407 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
48408 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
48409 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
48413 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48416 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
48417 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
48418 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
48421 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
48422 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48425 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
48426 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48429 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
48430 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
48433 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
48434 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48437 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
48438 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48443 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
48444 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
48445 *(G2**2-G1**2/3D0)*TPD
48446 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
48447 *1D0/16D0/PI**2*G1**2*HU**2*TP
48448 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
48449 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
48450 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
48451 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
48453 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
48454 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
48455 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
48456 *+ (3D0*HD**2/2D0 + HU**2/2D0
48457 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
48458 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
48459 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
48460 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
48461 *(TP + TDP)/8D0/PI**2)
48462 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
48463 *+ (3D0*HU**2/2D0 + HD**2/2D0
48464 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
48465 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
48466 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
48467 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48468 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
48469 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
48470 LAMBDA4 = (- G2**2/2D0)*(1D0
48471 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
48472 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
48478 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
48479 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
48481 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
48482 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
48483 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
48484 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
48487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48488 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
48489 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48491 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
48493 IF(MCHI.GT.MSSUSY) GOTO 100
48494 IF(MCHI.LT.MTOP) MCHI=MTOP
48496 TCHAR=LOG(MSSUSY**2/MCHI**2)
48498 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
48499 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
48500 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
48502 DELTAM112=2D0*DELTAL12*V**2*COSB**2
48503 DELTAM222=2D0*DELTAL12*V**2*SINB**2
48504 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
48506 M2(1,1)=M2(1,1)+DELTAM112
48507 M2(2,2)=M2(2,2)+DELTAM222
48508 M2(1,2)=M2(1,2)+DELTAM122
48509 M2(2,1)=M2(2,1)+DELTAM122
48513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48514 CCC END OF CHARGINOS/NEUTRALINOS
48515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48519 M2P(I,J) = M2(I,J) + VH(I,J)
48522 TRM2P = M2P(1,1) + M2P(2,2)
48523 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
48524 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48525 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48527 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
48529 IF(MH2P.LT.0.) GOTO 130
48531 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
48532 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
48533 IF(COS2ALPHA.GE.0.) THEN
48534 ALPHA = ASIN(SIN2ALPHA)/2D0
48536 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
48540 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48542 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
48543 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
48544 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
48547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48548 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
48549 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
48554 C*********************************************************************
48557 C...Auxiliary to PYRGHM.
48559 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
48560 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
48561 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
48562 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
48564 INTEGER MSTU,MSTJ,KCHG
48565 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48566 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48567 SAVE /PYDAT1/,/PYDAT2/
48569 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
48571 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
48572 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
48574 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
48579 SINBA = TANBA/DSQRT(TANBA**2+1D0)
48580 COSBA = SINBA/TANBA
48582 SINB = TANB/DSQRT(TANB**2+1D0)
48588 SW = 1D0-MW**2/MZ**2
48591 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
48592 G2 = DSQRT(0.0336D0*4D0*PI)
48593 G1 = DSQRT(0.0101D0*4D0*PI)
48595 IF(MQ.GT.MUR) MST = MQ
48596 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
48598 MSUSYT = DSQRT(MST**2 + MTOP**2)
48600 IF(MQ.GT.MD) MSB = MQ
48601 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
48603 MB = PYMRUN(5,MSB**2)
48604 MSUSYB = DSQRT(MSB**2 + MB**2)
48605 TT = LOG(MSUSYT**2/MTOP**2)
48606 TB = LOG(MSUSYB**2/MTOP**2)
48608 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48609 HT = RMTOP/(V*SINB)
48612 G32 = ALPHA3*4D0*PI
48613 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
48614 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
48615 AL2 = 3D0/8D0/PI**2*HT**2
48616 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
48617 C ALST = 3./8./PI**2*HTST**2
48618 AL1 = 3D0/8D0/PI**2*HB**2
48621 AL(1,2) = (AL2+AL1)/2D0
48622 AL(2,1) = (AL2+AL1)/2D0
48625 IF(MA.GT.MTOP) THEN
48626 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
48627 * LOG(MTOP**2/MA**2))
48630 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
48631 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
48632 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
48633 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
48638 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48639 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48640 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48641 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48645 SINBT = TANBST/DSQRT(1D0+TANBST**2)
48648 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
48649 COSBB = SINBB/TANBSB
48654 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48655 MTOP2 = DSQRT(MTOP4)
48656 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48657 * /(1D0+DELTAMB)**4
48658 MBOT2 = DSQRT(MBOT4)
48660 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48661 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48662 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48663 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48664 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48665 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48666 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48667 * MQ2 - MUR2)**2*0.25D0
48668 * + MTOP2*(AT-XMU/TANBST)**2)
48669 IF(STOP22.LT.0.) GOTO 120
48670 SBOT12 = (MQ2 + MD2)*.5D0
48671 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48672 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48673 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48674 SBOT22 = (MQ2 + MD2)*.5D0
48675 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48676 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48677 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48678 IF(SBOT22.LT.0.) SBOT22 = 10000D0
48680 STOP1 = DSQRT(STOP12)
48681 STOP2 = DSQRT(STOP22)
48682 SBOT1 = DSQRT(SBOT12)
48683 SBOT2 = DSQRT(SBOT22)
48685 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48687 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
48688 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
48689 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
48690 C INDUCED CORRECTIONS.
48692 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48697 IF(X.EQ.Y) X = X - 0.00001D0
48698 IF(X.EQ.Z) X = X - 0.00002D0
48699 IF(Y.EQ.Z) Y = Y - 0.00003D0
48705 IF(X.EQ.Y) X = X - 0.00001D0
48706 IF(X.EQ.Z) X = X - 0.00002D0
48707 IF(Y.EQ.Z) Y = Y - 0.00003D0
48709 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
48710 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
48714 IF(X.EQ.Y) X = X - 0.00001D0
48715 IF(X.EQ.Z) X = X - 0.00002D0
48716 IF(Y.EQ.Z) Y = Y - 0.00003D0
48718 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
48720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48722 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
48723 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
48724 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
48725 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
48726 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
48727 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
48728 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
48729 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
48730 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
48731 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
48732 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
48735 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48737 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48738 MTOP2 = DSQRT(MTOP4)
48739 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48740 * /(1D0+DELTAMB)**4
48741 MBOT2 = DSQRT(MBOT4)
48743 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48744 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48745 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48746 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48747 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48748 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48749 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48750 * MQ2 - MUR2)**2*0.25D0
48751 * + MTOP2*(AT-XMU/TANBST)**2)
48753 IF(STOP22.LT.0.) GOTO 120
48754 SBOT12 = (MQ2 + MD2)*.5D0
48755 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48756 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48757 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48758 SBOT22 = (MQ2 + MD2)*.5D0
48759 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48760 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48761 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48762 IF(SBOT22.LT.0.) GOTO 120
48765 STOP1 = DSQRT(STOP12)
48766 STOP2 = DSQRT(STOP22)
48767 SBOT1 = DSQRT(SBOT12)
48768 SBOT2 = DSQRT(SBOT22)
48770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48775 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
48777 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
48778 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
48780 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
48782 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
48783 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
48785 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
48786 * (-.5D0*LOG(STOP12/STOP22)
48787 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
48788 * G(STOP12,STOP22))
48790 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
48791 * (.5D0*LOG(SBOT12/SBOT22)
48792 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
48793 * G(SBOT12,SBOT22))
48795 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
48796 * (MQ2+MBOT2)/(MD2+MBOT2))
48797 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
48798 * LOG(SBOT1**2/SBOT2**2)) +
48799 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
48800 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
48803 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
48804 * -STOP2**2))**2*G(STOP12,STOP22)
48806 VH3B(1,1)=VH3B(1,1)+
48807 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
48809 VH3T(1,1) = VH3T(1,1) +
48810 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
48812 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
48813 * (MQ2+MTOP2)/(MUR2+MTOP2))
48814 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
48815 * LOG(STOP1**2/STOP2**2)) +
48816 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
48817 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
48820 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
48821 * -SBOT2**2))**2*G(SBOT12,SBOT22)
48823 VH3T(2,2)=VH3T(2,2)+
48824 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
48825 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
48827 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
48828 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
48829 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
48832 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
48833 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
48834 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
48837 VH3T(1,2)=VH3T(1,2) +
48838 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
48840 VH3B(1,2)=VH3B(1,2) +
48841 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
48843 VH3T(2,1) = VH3T(1,2)
48844 VH3B(2,1) = VH3B(1,2)
48846 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
48847 C TU = LOG((MUR2+MTOP2)/MTOP2)
48848 C TQD = LOG((MQ2 + MB**2)/MB**2)
48849 C TD = LOG((MD2+MB**2)/MB**2)
48854 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
48855 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
48856 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
48857 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
48876 C*********************************************************************
48879 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
48881 FUNCTION PYFINT(A,B,C)
48883 C...Double precision and integer declarations.
48884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48885 IMPLICIT INTEGER(I-N)
48886 INTEGER PYK,PYCHGE,PYCOMP
48888 COMMON/PYINTS/XXM(20)
48891 C...Local variables.
48893 DOUBLE PRECISION PYFISB
48900 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
48905 C*********************************************************************
48908 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
48912 C...Double precision and integer declarations.
48913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48914 IMPLICIT INTEGER(I-N)
48915 INTEGER PYK,PYCHGE,PYCOMP
48917 COMMON/PYINTS/XXM(20)
48920 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
48921 &(X*(XXM(2)-XXM(3))+XXM(3)))
48926 C*********************************************************************
48929 C...Calculates decays of sfermions.
48931 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
48933 C...Double precision and integer declarations.
48934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48935 IMPLICIT INTEGER(I-N)
48936 INTEGER PYK,PYCHGE,PYCOMP
48937 C...Parameter statement to help give large particle numbers.
48938 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48939 &KEXCIT=4000000,KDIMEN=5000000)
48941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48944 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48945 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48948 C...Local variables.
48949 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
48950 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
48952 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
48953 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48954 DOUBLE PRECISION PYLAMF,XL
48955 DOUBLE PRECISION TANW,XW,AEM,C1,AS
48956 DOUBLE PRECISION AL,AR,BL,BR
48957 DOUBLE PRECISION CH1,CH2,CH3,CH4
48958 DOUBLE PRECISION XMBOT,XMTOP
48959 DOUBLE PRECISION XLAM(0:400)
48960 INTEGER IDLAM(400,3)
48961 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
48962 DOUBLE PRECISION SR2
48963 DOUBLE PRECISION CBETA,SBETA
48964 DOUBLE PRECISION CW
48965 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
48966 DOUBLE PRECISION COSA,SINA,TANB
48967 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
48968 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
48970 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
48971 DATA IGG/23,25,35,36/
48972 DATA PI/3.141592654D0/
48973 DATA SR2/1.4142136D0/
48974 DATA KFNCHI/1000022,1000023,1000025,1000035/
48975 DATA KFCCHI/1000024,1000037/
48977 C...COUNT THE NUMBER OF DECAY MODES
48981 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
48982 &KFIN.EQ.KSUSY2+16) RETURN
48988 TANW = SQRT(XW/(1D0-XW))
48993 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
48998 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
48999 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49005 C...ILR is 1 for left and 2 for right.
49007 C...IFL is matching non-SUSY flavour.
49008 IFL=MOD(KFIN,KSUSY1)
49009 C...IDU is weak isospin, 1 for down and 2 for up.
49020 XMBOT=PYMRUN(5,XMI2)
49021 XMTOP=PYMRUN(6,XMI2)
49035 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49037 IF(IMSS(11).EQ.1) THEN
49040 XMGR=PMAS(PYCOMP(IDG),1)
49041 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
49044 ELSEIF(IFL.EQ.6) THEN
49049 IF(XMI.GT.XMGR+XMF) THEN
49054 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
49058 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49060 C...CHARGED DECAYS:
49062 C...DI -> U CHI1-,CHI2-
49066 C...UI -> D CHI1+,CHI2+
49073 IF(XMI.GE.AXMJ+XMFP) THEN
49080 ELSEIF(IFL.LT.6) THEN
49085 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
49086 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
49092 ELSEIF(IFL.LT.5) THEN
49097 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
49098 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
49102 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49103 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49104 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49105 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49121 XL=PYLAMF(XMI2,XMA2,XMB2)
49122 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49123 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49124 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
49127 IDLAM(LKNT,1)=-KFCCHI(IX)
49128 IDLAM(LKNT,2)=IFL+1
49130 IDLAM(LKNT,1)=KFCCHI(IX)
49131 IDLAM(LKNT,2)=IFL-1
49142 IF(XMI.GE.AXMJ+XMF) THEN
49148 ELSEIF(IFL.LT.5) THEN
49151 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
49152 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
49153 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49158 ELSEIF(IFL.LT.5) THEN
49161 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
49162 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
49163 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49167 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49168 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49169 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49170 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49186 XL=PYLAMF(XMI2,XMA2,XMB2)
49187 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49188 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49189 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
49190 IDLAM(LKNT,1)=KFNCHI(IX)
49196 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
49200 IF(ILR.EQ.1) GOTO 160
49202 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
49203 IF(XMI.LT.XMSF1+XMB) GOTO 160
49205 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
49208 ELSEIF(IG.EQ.25) THEN
49211 ELSEIF(IFL.EQ.6) THEN
49213 ELSEIF(IFL.LT.5) THEN
49219 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49220 & XMF**2/XMW*COSA/SBETA
49221 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49222 & XMF**2/XMW*COSA/SBETA
49224 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49225 & XMF**2/XMW*(-SINA)/CBETA
49226 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49227 & XMF**2/XMW*(-SINA)/CBETA
49231 ELSEIF(IFL.EQ.6) THEN
49233 ELSEIF(IFL.EQ.15) THEN
49238 C.........need to complexify
49240 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
49243 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
49249 ELSEIF(IG.EQ.35) THEN
49252 ELSEIF(IFL.EQ.6) THEN
49254 ELSEIF(IFL.LT.5) THEN
49260 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49261 & XMF**2/XMW*SINA/SBETA
49262 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49263 & XMF**2/XMW*SINA/SBETA
49265 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49266 & XMF**2/XMW*COSA/CBETA
49267 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49268 & XMF**2/XMW*COSA/CBETA
49272 ELSEIF(IFL.EQ.6) THEN
49274 ELSEIF(IFL.EQ.15) THEN
49279 C.........Need to complexify
49281 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
49284 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
49290 ELSEIF(IG.EQ.36) THEN
49295 ELSEIF(IFL.EQ.6) THEN
49297 ELSEIF(IFL.LT.5) THEN
49304 ELSEIF(IFL.EQ.6) THEN
49306 ELSEIF(IFL.EQ.15) THEN
49311 C.........Need to complexify
49313 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
49315 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
49321 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
49322 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
49323 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
49324 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49327 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49329 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
49332 IDLAM(LKNT,1)=KFIN-KSUSY1
49338 IF(MOD(IFL,2).EQ.0) THEN
49344 XMSF1=PMAS(PYCOMP(KF1),1)
49345 XMSF2=PMAS(PYCOMP(KF2),1)
49346 IF(XMI.GT.XMB+XMSF1) THEN
49347 IF(MOD(IFL,2).EQ.0) THEN
49349 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
49351 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
49355 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
49357 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
49360 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49362 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49365 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49367 IF(XMI.GT.XMB+XMSF2) THEN
49368 IF(MOD(IFL,2).EQ.0) THEN
49370 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
49372 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
49376 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
49378 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
49381 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
49383 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49386 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49391 IF(MOD(IFL,2).EQ.0) THEN
49397 XMSF1=PMAS(PYCOMP(KF1),1)
49398 XMSF2=PMAS(PYCOMP(KF2),1)
49399 IF(XMI.GT.XMB+XMSF1) THEN
49404 IF(MOD(IFL,2).EQ.0) THEN
49407 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
49408 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
49409 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
49410 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
49413 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
49414 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
49415 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
49416 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
49427 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
49428 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
49429 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
49430 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
49433 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
49434 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
49435 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
49436 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
49445 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49447 C.......Need to complexify
49448 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49449 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49450 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49451 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49454 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49456 IF(XMI.GT.XMB+XMSF2) THEN
49461 IF(MOD(IFL,2).EQ.0) THEN
49464 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
49465 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
49466 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
49467 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
49470 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
49471 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
49472 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
49473 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
49484 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
49485 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
49486 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
49487 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
49490 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
49491 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
49492 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
49493 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
49502 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49504 C.......Need to complexify
49505 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49506 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49507 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49508 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49511 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49514 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
49519 IF(IFL.EQ.6) XMF=PMAS(6,1)
49520 IF(IFL.EQ.5) XMF=PMAS(5,1)
49521 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
49523 IF(XMI.GE.AXMJ+XMF) THEN
49540 XL=PYLAMF(XMI2,XMA2,XMB2)
49541 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49542 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
49543 IDLAM(LKNT,1)=KSUSY1+21
49549 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
49550 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
49551 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
49552 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
49553 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
49554 C...M*M = C1**2 * G**2/(16PI**2)
49555 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
49557 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
49558 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
49559 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
49560 IDLAM(LKNT,1)=KSUSY1+22
49565 C...R-violating sfermion decays (SKANDS).
49566 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
49571 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49572 XLAM(0)=XLAM(0)+XLAM(I)
49574 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
49579 C*********************************************************************
49582 C...Calculates gluino decay modes.
49584 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
49586 C...Double precision and integer declarations.
49587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49588 IMPLICIT INTEGER(I-N)
49589 INTEGER PYK,PYCHGE,PYCOMP
49590 C...Parameter statement to help give large particle numbers.
49591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49592 &KEXCIT=4000000,KDIMEN=5000000)
49594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49596 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49597 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49598 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49600 C COMMON/PYINTS/XXM(20)
49602 COMMON/PYINTC/XXC(10),CXC(8)
49603 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49605 C...Local variables
49606 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49607 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
49608 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49609 DOUBLE PRECISION PYLAMF,XL
49610 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
49611 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
49612 DOUBLE PRECISION XLAM(0:400)
49613 INTEGER IDLAM(400,3)
49614 INTEGER LKNT,IX,ILR,I,IKNT,IFL
49615 DOUBLE PRECISION SR2
49616 DOUBLE PRECISION GAM
49617 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
49618 EXTERNAL PYGAUS,PYXXZ6
49619 DOUBLE PRECISION PYGAUS,PYXXZ6
49620 DOUBLE PRECISION PREC
49621 INTEGER KFNCHI(4),KFCCHI(2)
49622 DATA PI/3.141592654D0/
49623 DATA SR2/1.4142136D0/
49625 DATA KFNCHI/1000022,1000023,1000025,1000035/
49626 DATA KFCCHI/1000024,1000037/
49628 C...COUNT THE NUMBER OF DECAY MODES
49630 IF(KFIN.NE.KSUSY1+21) RETURN
49634 TANW = SQRT(XW/(1D0-XW))
49644 XMI=SIGN(XMI,RMSS(3))
49646 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
49648 IF(IMSS(11).EQ.1) THEN
49651 XMGR=PMAS(PYCOMP(IDG),1)
49652 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49653 IF(AXMI.GT.XMGR) THEN
49662 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
49666 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
49669 IF(AXMI.GE.AXMJ+XMF) THEN
49670 C...Minus sign difference from gluino-quark-squark feynman rules
49687 XL=PYLAMF(XMI2,XMA2,XMB2)
49688 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
49689 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
49690 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
49694 XLAM(LKNT)=XLAM(LKNT-1)
49695 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49696 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49702 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
49703 C...GLUINO -> NI Q QBAR
49707 IF(AXMI.GE.AXMJ) THEN
49709 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
49711 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
49718 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49719 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49725 T3I=SIGN(1D0,EI+1D-6)/2D0
49726 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49727 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49731 CXC(4)=DCONJG(GLIJ)
49735 CXC(8)=-DCONJG(GRIJ)
49737 S12MAX=(AXMI-AXMJ)**2
49738 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
49739 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49741 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49742 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49743 IDLAM(LKNT,1)=KFNCHI(IX)
49747 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49749 XLAM(LKNT)=XLAM(LKNT-1)
49750 IDLAM(LKNT,1)=KFNCHI(IX)
49755 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49756 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
49757 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
49759 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
49760 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
49762 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
49765 IDLAM(LKNT,1)=KFNCHI(IX)
49768 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
49773 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49774 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49775 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
49779 T3I=SIGN(1D0,EI+1D-6)/2D0
49780 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49781 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49783 CXC(4)=DCONJG(GLIJ)
49785 CXC(8)=-DCONJG(GRIJ)
49786 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
49787 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49789 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49790 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49791 IDLAM(LKNT,1)=KFNCHI(IX)
49795 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49797 XLAM(LKNT)=XLAM(LKNT-1)
49798 IDLAM(LKNT,1)=KFNCHI(IX)
49803 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
49804 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
49806 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
49807 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
49808 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
49810 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
49811 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
49813 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
49816 IDLAM(LKNT,1)=KFNCHI(IX)
49819 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
49825 C...GLUINO -> CI Q QBAR'
49829 IF(AXMI.GE.AXMJ) THEN
49831 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
49832 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
49835 S12MAX=(AXMI-AXMJ)**2
49840 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
49841 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
49844 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
49846 CXC(1)=DCMPLX(0D0,0D0)
49847 CXC(3)=DCMPLX(0D0,0D0)
49848 CXC(5)=DCMPLX(0D0,0D0)
49849 CXC(7)=DCMPLX(0D0,0D0)
49850 CXC(2)=UMIXC(IX,1)*OLPP/SR2
49851 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
49852 CXC(6)=DCMPLX(0D0,0D0)
49853 CXC(8)=DCMPLX(0D0,0D0)
49854 IF(XXC(5).LT.AXMI) THEN
49856 ELSEIF(XXC(6).LT.AXMI) THEN
49861 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
49862 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
49864 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
49865 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49866 IDLAM(LKNT,1)=KFCCHI(IX)
49870 XLAM(LKNT)=XLAM(LKNT-1)
49871 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49872 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49873 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49875 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49877 XLAM(LKNT)=XLAM(LKNT-1)
49878 IDLAM(LKNT,1)=KFCCHI(IX)
49882 XLAM(LKNT)=XLAM(LKNT-1)
49883 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49884 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49885 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49891 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
49892 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
49893 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
49894 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
49895 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
49896 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
49897 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
49898 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
49899 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
49900 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
49901 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
49902 CALL PYTBBC(IX,100,XMI,GAM)
49905 IDLAM(LKNT,1)=KFCCHI(IX)
49909 XLAM(LKNT)=XLAM(LKNT-1)
49910 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49911 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49912 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49913 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
49914 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
49915 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
49916 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
49922 C...R-parity violating (3-body) decays.
49923 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
49928 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49929 XLAM(0)=XLAM(0)+XLAM(I)
49931 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
49937 C*********************************************************************
49940 C...Calculates the three-body decay of gluinos into
49941 C...neutralinos and third generation fermions.
49943 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
49945 C...Double precision and integer declarations.
49946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49947 IMPLICIT INTEGER(I-N)
49948 INTEGER PYK,PYCHGE,PYCOMP
49949 C...Parameter statement to help give large particle numbers.
49950 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49951 &KEXCIT=4000000,KDIMEN=5000000)
49953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49956 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49957 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49958 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49960 C...Local variables.
49961 EXTERNAL PYSIMP,PYLAMF
49962 DOUBLE PRECISION PYSIMP,PYLAMF
49964 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
49965 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
49966 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
49967 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
49968 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
49969 DOUBLE PRECISION XLN1,XLN2,B1,B2
49970 DOUBLE PRECISION E,XMGLU,GAM
49971 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
49972 SAVE HRB,HLB,FLB,FRB
49973 DOUBLE PRECISION ALPHAW,ALPHAS
49974 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
49975 SAVE HLT,HRT,FLT,FRT
49976 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
49978 DOUBLE PRECISION AMBOT,SINC,COSC
49979 DOUBLE PRECISION AMTOP,SINA,COSA
49980 DOUBLE PRECISION SINW,COSW,TANW
49981 DOUBLE PRECISION ROT1(4,4)
49984 DATA IFIRST/.TRUE./
49987 SINB=TANB/SQRT(1D0+TANB**2)
49998 AMBOT=PYMRUN(5,XMGLU**2)
49999 AMTOP=PYMRUN(6,XMGLU**2)
50001 FAKT1=AMBOT/W2/AMW/COSB
50002 FAKT2=AMTOP/W2/AMW/SINB
50013 ROT1(2,1)=-ROT1(1,2)
50014 ROT1(2,2)=ROT1(1,1)
50017 ROT1(4,3)=-ROT1(3,4)
50018 ROT1(4,4)=ROT1(3,3)
50022 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
50027 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
50028 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50029 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
50031 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
50032 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
50033 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
50034 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
50037 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
50038 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50039 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
50040 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
50041 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
50042 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
50043 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
50047 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50048 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50049 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50050 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50054 IF(NINT(3D0*E).EQ.2) THEN
50061 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
50062 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
50071 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
50072 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
50078 SIN2D=SIND*COSD*2D0
50092 ALPHAW=PYALEM(XMG2)
50093 ALPHAS=PYALPS(XMG2)
50097 XM24=(XMG2+XM2)*(XM2+XMR2)
50099 SMAX=(XMG-ABS(XMR))**2
50100 XMQA=XMG2+2D0*XM2+XMR2
50102 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50104 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
50106 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
50107 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
50108 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
50109 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
50110 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
50111 & +2D0*(FF*SIND2-HH*COSD2))*W
50112 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
50113 & +4D0*HFL*XM*XMR)*XLN1
50114 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
50115 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
50116 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
50117 & +8D0*HFL*XMQ4*SIN2D)*B1
50118 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
50119 & +4D0*HFR*XMR*XM)*XLN2
50120 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
50121 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
50122 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
50123 & -8D0*HFR*XMQ4*SIN2D)*B2
50124 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
50125 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
50126 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
50127 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
50128 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
50129 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
50130 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
50131 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
50132 G(5)=(2D0*(HH*COSD2-FF*SIND2)
50133 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
50134 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
50135 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
50136 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
50137 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
50138 & +COS2D*XM*(SBAR+XMG2-XMR2))
50139 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
50140 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
50141 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
50142 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
50143 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
50144 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
50145 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
50148 SUMME(LIN)=SUMME(LIN)+G(J)
50153 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50154 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50159 C*********************************************************************
50162 C...Calculates the three-body decay of gluinos into
50163 C...charginos and third generation fermions.
50165 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
50167 C...Double precision and integer declarations.
50168 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50169 IMPLICIT INTEGER(I-N)
50170 INTEGER PYK,PYCHGE,PYCOMP
50171 C...Parameter statement to help give large particle numbers.
50172 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50173 &KEXCIT=4000000,KDIMEN=5000000)
50175 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50176 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50177 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50178 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50179 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50180 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50182 C...Local variables.
50183 EXTERNAL PYSIMP,PYLAMF
50184 DOUBLE PRECISION PYSIMP,PYLAMF
50186 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
50187 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
50188 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
50189 DOUBLE PRECISION SUMME(0:100),A(4,8)
50190 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
50191 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
50192 DOUBLE PRECISION XMGLU,GAM
50193 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
50194 &DDD(2),EEE(2),FFF(2)
50195 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
50196 DOUBLE PRECISION ALPHAW,ALPHAS
50197 DOUBLE PRECISION AMC(2)
50199 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
50200 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
50204 DATA IFIRST/.TRUE./
50207 SINB=TANB/SQRT(1D0+TANB**2)
50215 AMBOT=PYMRUN(5,XMGLU**2)
50216 AMTOP=PYMRUN(6,XMGLU**2)
50219 FAKT1=AMBOT/W2/AMW/COSB
50220 FAKT2=AMTOP/W2/AMW/SINB
50225 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
50226 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
50227 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
50228 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
50229 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
50230 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
50231 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
50232 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
50234 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50235 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50236 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50237 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50241 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
50242 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
50243 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
50244 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
50246 COS2A=COSA**2-SINA**2
50247 SIN2A=SINA*COSA*2D0
50248 COS2C=COSC**2-SINC**2
50249 SIN2C=SINC*COSC*2D0
50256 ALPHAW=PYALEM(XMG2)
50257 ALPHAS=PYALPS(XMG2)
50261 XMQ2=XMG2+XMT2+XMB2+XMR2
50262 XMQ4=XMG*XMT*XMB*XMR
50263 XMQ3=XMG2*XMR2+XMT2*XMB2
50264 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
50265 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
50267 XMST(1)=AMST(1)*AMST(1)
50268 XMST(2)=AMST(1)*AMST(1)
50269 XMST(3)=AMST(2)*AMST(2)
50270 XMST(4)=AMST(2)*AMST(2)
50271 XMSB(1)=AMSB(1)*AMSB(1)
50272 XMSB(2)=AMSB(2)*AMSB(2)
50273 XMSB(3)=AMSB(1)*AMSB(1)
50274 XMSB(4)=AMSB(2)*AMSB(2)
50276 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
50277 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
50278 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
50279 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
50280 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
50281 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
50282 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
50283 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
50285 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
50286 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
50287 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
50288 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
50289 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
50290 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
50291 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
50292 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
50294 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
50295 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
50296 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
50297 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
50298 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
50299 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
50300 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
50301 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
50303 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
50304 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
50305 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
50306 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
50307 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
50308 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
50309 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
50310 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
50312 SMAX=(XMG-ABS(XMR))**2
50313 SMIN=(XMB+XMT)**2+0.1D0
50316 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50317 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
50319 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
50320 W=DSQRT(W)/2D0/SBAR
50321 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
50322 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
50323 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
50324 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
50325 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
50326 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
50327 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
50328 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
50329 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
50330 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
50331 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
50332 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
50333 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
50334 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
50335 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
50336 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
50337 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
50338 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
50339 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
50340 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
50341 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
50342 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
50343 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
50344 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
50345 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
50346 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
50347 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
50348 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
50349 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
50350 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
50351 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
50352 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
50353 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
50354 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
50355 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
50356 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
50357 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
50358 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
50359 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
50360 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
50361 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
50362 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
50363 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
50365 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
50366 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
50367 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
50368 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
50369 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
50370 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
50371 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
50372 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
50373 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
50374 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
50375 & -A(J,6)*(XMG2+XMR2-SBAR)
50376 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
50377 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
50378 & /(GRS+XMSB(J)+XMST(J))
50382 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50383 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50388 C*********************************************************************
50391 C...Calculates decay widths for the neutralinos (admixtures of
50392 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
50394 C...Input: KCIN = KF code for particle
50395 C...Output: XLAM = widths
50396 C... IDLAM = KF codes for decay particles
50397 C... IKNT = number of decay channels defined
50398 C...AUTHOR: STEPHEN MRENNA
50400 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
50401 C...when CHIGAMMA .NE. 0
50402 C...10 FEB 96: Calculate this decay for small tan(beta)
50404 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
50406 C...Double precision and integer declarations.
50407 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50408 IMPLICIT INTEGER(I-N)
50409 INTEGER PYK,PYCHGE,PYCOMP
50410 C...Parameter statement to help give large particle numbers.
50411 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50412 &KEXCIT=4000000,KDIMEN=5000000)
50414 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50415 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50416 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50417 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50419 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50420 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50421 C COMMON/PYINTS/XXM(20)
50423 COMMON/PYINTC/XXC(10),CXC(8)
50424 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50426 C...Local variables.
50427 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50428 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
50430 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50431 &XMZ,XMZ2,AXMJ,AXMI
50432 DOUBLE PRECISION S12MIN,S12MAX
50433 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
50434 DOUBLE PRECISION PYLAMF,XL
50435 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
50436 DOUBLE PRECISION PYX2XH,PYX2XG
50437 DOUBLE PRECISION XLAM(0:400)
50438 INTEGER IDLAM(400,3)
50439 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
50440 INTEGER ITH(3),KF1,KF2
50442 DOUBLE PRECISION DH(3),EH(3)
50443 DOUBLE PRECISION SR2
50444 DOUBLE PRECISION CBETA,SBETA
50445 DOUBLE PRECISION GAMCON,XMT1,XMT2
50446 DOUBLE PRECISION PYALEM,PI,PYALPS
50447 DOUBLE PRECISION RAT1,RAT2
50448 DOUBLE PRECISION T3T,FCOL
50449 DOUBLE PRECISION ALFA,BETA,TANB
50450 DOUBLE PRECISION PYXXGA
50451 EXTERNAL PYGAUS,PYXXZ6
50452 DOUBLE PRECISION PYGAUS,PYXXZ6
50453 DOUBLE PRECISION PREC
50454 INTEGER KFNCHI(4),KFCCHI(2)
50458 DATA PI/3.141592654D0/
50459 DATA SR2/1.4142136D0/
50460 DATA KFNCHI/1000022,1000023,1000025,1000035/
50461 DATA KFCCHI/1000024,1000037/
50463 C...COUNT THE NUMBER OF DECAY MODES
50472 TANW = SQRT(XW/XW1)
50474 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
50476 IF(KFIN.EQ.KFNCHI(2)) IX=2
50477 IF(KFIN.EQ.KFNCHI(3)) IX=3
50478 IF(KFIN.EQ.KFNCHI(4)) IX=4
50498 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50503 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50504 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50508 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50509 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
50511 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
50512 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
50516 GAMCON=AEM**3/8D0/PI/XMW2/XW
50517 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50518 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50519 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50520 IDLAM(LKNT,1)=KSUSY1+22
50523 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
50527 C...GRAVITINO DECAY MODES
50529 IF(IMSS(11).EQ.1) THEN
50532 XMGR=PMAS(PYCOMP(IDG),1)
50535 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50536 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
50541 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
50543 IF(AXMI.GT.XMGR+XMZ) THEN
50548 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
50549 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
50550 & (1D0-XMZ2/XMI2)**4
50552 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
50557 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
50558 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
50560 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
50565 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
50566 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
50568 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
50573 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
50574 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
50576 IF(IX.EQ.1) GOTO 300
50584 C...CHI0_I -> CHI0_J + GAMMA
50585 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
50586 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
50587 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
50588 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
50589 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
50590 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
50591 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
50593 IDLAM(LKNT,1)=KFNCHI(IJ)
50596 GAMCON=AEM**3/8D0/PI/XMW2/XW
50597 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50598 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50599 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50603 C...CHI0_I -> CHI0_J + Z0
50604 IF(AXMI.GE.AXMJ+XMZ) THEN
50606 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50607 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50609 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50610 GLR=DBLE(OLPP*DCONJG(ORPP))
50611 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50612 IDLAM(LKNT,1)=KFNCHI(IJ)
50615 ELSEIF(AXMI.GE.AXMJ) THEN
50622 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50623 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50625 C...CHARGED LEPTONS
50627 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50628 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50630 T3I=SIGN(1D0,EI+1D-6)/2D0
50631 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50632 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50633 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50634 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50636 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50637 CXC(4)=DCONJG(GLIJ)
50638 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50640 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50641 CXC(8)=-DCONJG(GRIJ)
50643 S12MAX=(AXMI-AXMJ)**2
50644 IF( XXC(5).LT.AXMI ) THEN
50647 IF(XXC(6).LT.AXMI ) THEN
50653 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50655 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50656 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50657 IDLAM(LKNT,1)=KFNCHI(IJ)
50660 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50662 XLAM(LKNT)=XLAM(LKNT-1)
50663 IDLAM(LKNT,1)=KFNCHI(IJ)
50669 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50670 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50671 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50673 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50674 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50676 IF( XXC(5).LT.AXMI ) THEN
50679 IF(XXC(6).LT.AXMI ) THEN
50685 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50687 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50688 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50689 IDLAM(LKNT,1)=KFNCHI(IJ)
50697 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50698 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50700 T3I=SIGN(1D0,EI+1D-6)/2D0
50701 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50702 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50703 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50704 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50706 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50707 CXC(4)=DCONJG(GLIJ)
50708 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50710 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50711 CXC(8)=-DCONJG(GRIJ)
50713 S12MAX=(AXMI-AXMJ)**2
50714 IF( XXC(5).LT.AXMI ) THEN
50717 IF( XXC(6).LT.AXMI ) THEN
50724 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50725 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50726 IDLAM(LKNT,1)=KFNCHI(IJ)
50730 XLAM(LKNT)=XLAM(LKNT-1)
50731 IDLAM(LKNT,1)=KFNCHI(IJ)
50736 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
50738 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50739 IF( XXC(5).LT.AXMI ) THEN
50744 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50745 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50748 XLAM(LKNT)=XLAM(LKNT-1)
50750 IDLAM(LKNT,1)=KFNCHI(IJ)
50756 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50757 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50759 T3I=SIGN(1D0,EI+1D-6)/2D0
50760 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50761 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50762 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50763 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50765 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50766 CXC(4)=DCONJG(GLIJ)
50767 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50769 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50770 CXC(8)=-DCONJG(GRIJ)
50772 S12MAX=(AXMI-AXMJ)**2
50773 IF( XXC(5).LT.AXMI ) THEN
50776 IF( XXC(6).LT.AXMI ) THEN
50782 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50784 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50785 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50786 IDLAM(LKNT,1)=KFNCHI(IJ)
50789 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50791 XLAM(LKNT)=XLAM(LKNT-1)
50792 IDLAM(LKNT,1)=KFNCHI(IJ)
50798 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50799 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50800 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50802 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50803 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50805 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50806 IF(XXC(5).LT.AXMI) THEN
50808 ELSEIF(XXC(6).LT.AXMI) THEN
50813 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50815 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50816 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50817 IDLAM(LKNT,1)=KFNCHI(IJ)
50825 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50826 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50828 T3I=SIGN(1D0,EI+1D-6)/2D0
50829 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50830 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50831 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50832 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50834 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50835 CXC(4)=DCONJG(GLIJ)
50836 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50838 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50839 CXC(8)=-DCONJG(GRIJ)
50841 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
50842 IF(XXC(5).LT.AXMI) THEN
50844 ELSEIF(XXC(6).LT.AXMI) THEN
50850 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50852 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50853 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50854 IDLAM(LKNT,1)=KFNCHI(IJ)
50857 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50859 XLAM(LKNT)=XLAM(LKNT-1)
50860 IDLAM(LKNT,1)=KFNCHI(IJ)
50868 C...CHI0_I -> CHI0_J + H0_K
50875 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
50876 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
50877 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
50878 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
50879 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
50880 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
50881 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
50882 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
50884 XMH=PMAS(ITH(IH),1)
50886 IF(AXMI.GE.AXMJ+XMH) THEN
50888 XL=PYLAMF(XMI2,XMJ2,XMH2)
50889 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
50891 C...SIGN OF MASSES I,J
50893 IF(IH.EQ.3) XMK=-XMK
50894 GX2=ABS(F21K)**2+ABS(F12K)**2
50895 GLR=DBLE(F21K*DCONJG(F12K))
50896 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50897 IDLAM(LKNT,1)=KFNCHI(IJ)
50898 IDLAM(LKNT,2)=ITH(IH)
50904 C...CHI0_I -> CHI+_J + W-
50909 IF(AXMI.GE.AXMJ+XMW) THEN
50911 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50912 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
50913 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50914 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
50915 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50916 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50917 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50918 IDLAM(LKNT,1)=KFCCHI(IJ)
50922 XLAM(LKNT)=XLAM(LKNT-1)
50923 IDLAM(LKNT,1)=-KFCCHI(IJ)
50926 ELSEIF(AXMI.GE.AXMJ) THEN
50928 S12MAX=(AXMI-AXMJ)**2
50929 RT2I = 1D0/SQRT(2D0)
50930 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50931 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
50932 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50933 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
50934 CXC(5)=DCMPLX(0D0,0D0)
50935 CXC(7)=DCMPLX(0D0,0D0)
50939 T3I=SIGN(1D0,EI+1D-6)/2D0
50941 T3J=SIGN(1D0,EJ+1D-6)/2D0
50942 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
50943 & TANW+ZMIXC(IX,2)*T3J)*RT2I
50944 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
50945 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
50946 CXC(6)=DCMPLX(0D0,0D0)
50947 CXC(8)=DCMPLX(0D0,0D0)
50952 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50953 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50956 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
50957 IF(XXC(5).LT.AXMI) THEN
50959 ELSEIF(XXC(6).LT.AXMI) THEN
50964 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50966 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50967 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50968 IDLAM(LKNT,1)=KFCCHI(IJ)
50972 XLAM(LKNT)=XLAM(LKNT-1)
50973 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50974 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50975 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50976 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50978 XLAM(LKNT)=XLAM(LKNT-1)
50979 IDLAM(LKNT,1)=KFCCHI(IJ)
50983 XLAM(LKNT)=XLAM(LKNT-1)
50984 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50985 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50986 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50990 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50991 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50992 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50994 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50995 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50997 IF(XXC(5).LT.AXMI) THEN
51000 IF(XXC(6).LT.AXMI) THEN
51005 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51007 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51008 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51009 XLAM(LKNT)=XLAM(LKNT-1)
51010 IDLAM(LKNT,1)=KFCCHI(IJ)
51014 XLAM(LKNT)=XLAM(LKNT-1)
51015 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51016 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51017 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51020 C...NOW, DO THE QUARKS
51025 T3I=SIGN(1D0,EI+1D-6)/2D0
51027 T3J=SIGN(1D0,EJ+1D-6)/2D0
51028 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51029 & TANW+ZMIXC(IX,2)*T3J)
51030 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51031 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
51032 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51033 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
51034 IF(XXC(5).LT.AXMI) THEN
51037 IF(XXC(6).LT.AXMI) THEN
51042 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
51044 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51045 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51046 IDLAM(LKNT,1)=KFCCHI(IJ)
51050 XLAM(LKNT)=XLAM(LKNT-1)
51051 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51052 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51053 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51054 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51056 XLAM(LKNT)=XLAM(LKNT-1)
51057 IDLAM(LKNT,1)=KFCCHI(IJ)
51061 XLAM(LKNT)=XLAM(LKNT-1)
51062 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51063 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51064 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51072 C...CHI0_I -> CHI+_I + H-
51078 IF(AXMI.GE.AXMJ+XMHP) THEN
51080 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
51081 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
51082 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
51083 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
51085 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51086 GLR=DBLE(OLPP*DCONJG(ORPP))
51087 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51088 IDLAM(LKNT,1)=KFCCHI(IJ)
51089 IDLAM(LKNT,2)=-ITHC
51092 XLAM(LKNT)=XLAM(LKNT-1)
51093 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51094 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51095 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51101 C...2-BODY DECAYS TO FERMION SFERMION
51103 IF(J.GE.7.AND.J.LE.10) GOTO 290
51106 XMSF1=PMAS(PYCOMP(KF1),1)
51107 XMSF2=PMAS(PYCOMP(KF2),1)
51117 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
51118 IF(MOD(J,2).EQ.0) THEN
51119 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51120 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
51121 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51124 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51125 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
51126 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51131 IF(AXMI.GE.XMF+XMSF1) THEN
51135 XL=PYLAMF(XMI2,XMA2,XMB2)
51136 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
51137 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
51138 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51139 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51144 XLAM(LKNT)=XLAM(LKNT-1)
51145 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51146 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51151 IF(AXMI.GE.XMF+XMSF2) THEN
51155 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
51156 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
51157 XL=PYLAMF(XMI2,XMA2,XMB2)
51158 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51159 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51164 XLAM(LKNT)=XLAM(LKNT-1)
51165 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51166 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51171 C...3-BODY DECAY TO Q Q~ GLUINO
51172 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51173 IF(AXMI.GE.XMJ) THEN
51174 RT2I = 1D0/SQRT(2D0)
51175 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
51183 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51184 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51185 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
51191 T3I=SIGN(1D0,EI+1D-6)/2D0
51192 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51193 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51197 CXC(4)=DCONJG(GLIJ)
51201 CXC(8)=-DCONJG(GRIJ)
51203 S12MAX=(AXMI-AXMJ)**2
51204 C...ALL QUARKS BUT T
51205 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51207 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51208 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51209 IDLAM(LKNT,1)=KSUSY1+21
51212 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51214 XLAM(LKNT)=XLAM(LKNT-1)
51215 IDLAM(LKNT,1)=KSUSY1+21
51221 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51222 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51223 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51225 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51226 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51228 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
51231 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51233 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51234 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51235 IDLAM(LKNT,1)=KSUSY1+21
51242 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51243 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51244 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
51248 T3I=SIGN(1D0,EI+1D-6)/2D0
51249 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51250 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51252 CXC(4)=DCONJG(GLIJ)
51254 CXC(8)=-DCONJG(GRIJ)
51255 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51257 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51258 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51259 IDLAM(LKNT,1)=KSUSY1+21
51262 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51264 XLAM(LKNT)=XLAM(LKNT-1)
51265 IDLAM(LKNT,1)=KSUSY1+21
51273 C...R-violating decay modes (SKANDS).
51274 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
51279 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51280 XLAM(0)=XLAM(0)+XLAM(I)
51282 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51287 C*********************************************************************
51290 C...Calculate decay widths for the charginos (admixtures of
51291 C...charged Wino and charged Higgsino.
51293 C...Input: KCIN = KF code for particle
51294 C...Output: XLAM = widths
51295 C... IDLAM = KF codes for decay particles
51296 C... IKNT = number of decay channels defined
51297 C...AUTHOR: STEPHEN MRENNA
51299 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
51300 C...when CHIENU .NE. 0
51302 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
51304 C...Double precision and integer declarations.
51305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51306 IMPLICIT INTEGER(I-N)
51307 INTEGER PYK,PYCHGE,PYCOMP
51308 C...Parameter statement to help give large particle numbers.
51309 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51310 &KEXCIT=4000000,KDIMEN=5000000)
51312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51314 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51315 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51316 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51318 C COMMON/PYINTS/XXM(20)
51320 COMMON/PYINTC/XXC(10),CXC(8)
51321 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51323 C...Local variables
51324 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51325 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
51327 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51328 &XMZ,XMZ2,AXMJ,AXMI
51329 DOUBLE PRECISION S12MIN,S12MAX
51330 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
51331 DOUBLE PRECISION PYLAMF,XL
51332 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
51333 DOUBLE PRECISION PYX2XH,PYX2XG
51334 DOUBLE PRECISION XLAM(0:400)
51335 INTEGER IDLAM(400,3)
51336 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
51339 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
51340 DOUBLE PRECISION SR2
51341 DOUBLE PRECISION CBETA,SBETA,TANB
51343 DOUBLE PRECISION PYALEM,PI,PYALPS
51344 DOUBLE PRECISION FCOL
51345 INTEGER KF1,KF2,ISF
51346 INTEGER KFNCHI(4),KFCCHI(2)
51348 DOUBLE PRECISION TEMP
51349 EXTERNAL PYGAUS,PYXXZ6
51350 DOUBLE PRECISION PYGAUS,PYXXZ6
51351 DOUBLE PRECISION PREC
51354 DATA ETAH/1D0,1D0,-1D0/
51355 DATA SR2/1.4142136D0/
51356 DATA PI/3.141592654D0/
51358 DATA KFNCHI/1000022,1000023,1000025,1000035/
51359 DATA KFCCHI/1000024,1000037/
51361 C...COUNT THE NUMBER OF DECAY MODES
51369 TANW = SQRT(XW/XW1)
51371 C...1 OR 2 DEPENDING ON CHARGINO TYPE
51373 IF(KFIN.EQ.KFCCHI(2)) IX=2
51391 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51392 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51396 C...GRAVITINO DECAY MODES
51398 IF(IMSS(11).EQ.1) THEN
51401 XMGR=PMAS(PYCOMP(IDG),1)
51403 C COSW=SQRT(1D0-XW)
51404 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51405 IF(AXMI.GT.XMGR+XMW) THEN
51411 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
51412 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
51413 & (1D0-XMW2/XMI2)**4
51415 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
51420 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
51421 & (ABS(UMIXC(IX,2))*SBETA)**2))
51422 & *(1D0-PMAS(37,1)**2/XMI2)**4
51426 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51427 IF(IX.EQ.1) GOTO 170
51432 C...CHI_2+ -> CHI_1+ + Z0
51433 IF(AXMI.GE.AXMJ+XMZ) THEN
51436 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51437 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51438 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51439 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51440 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51441 GLR=DBLE(OLPP*DCONJG(ORPP))
51442 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51443 IDLAM(LKNT,1)=KFCCHI(1)
51447 C...CHARGED LEPTONS
51448 ELSEIF(AXMI.GE.AXMJ) THEN
51450 S12MAX=(AXMI-AXMJ)**2
51453 EI=KCHG(IABS(IA),1)/3D0
51454 T3I=SIGN(1D0,EI+1D-6)/2D0
51459 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51464 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51465 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51466 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51467 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51468 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51469 CXC(2)=DCMPLX(0D0,0D0)
51470 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51471 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51472 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51473 CXC(6)=DCMPLX(0D0,0D0)
51474 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51475 CXC(8)=DCMPLX(0D0,0D0)
51476 IF( XXC(5).LT.AXMI ) THEN
51481 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51483 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51484 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51485 IDLAM(LKNT,1)=KFCCHI(1)
51488 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51490 XLAM(LKNT)=XLAM(LKNT-1)
51491 IDLAM(LKNT,1)=KFCCHI(1)
51495 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51497 XLAM(LKNT)=XLAM(LKNT-1)
51498 IDLAM(LKNT,1)=KFCCHI(1)
51508 EI=KCHG(IABS(IA),1)/3D0
51509 T3I=SIGN(1D0,EI+1D-6)/2D0
51510 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51512 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51513 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51514 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51515 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51516 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51517 IF( XXC(5).LT.AXMI ) THEN
51522 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
51524 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51525 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51526 IDLAM(LKNT,1)=KFCCHI(1)
51530 XLAM(LKNT)=XLAM(LKNT-1)
51531 IDLAM(LKNT,1)=KFCCHI(1)
51535 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
51536 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51537 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51539 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51541 IF( XXC(5).LT.AXMI ) THEN
51546 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51547 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51548 IDLAM(LKNT,1)=KFCCHI(1)
51557 EI=KCHG(IABS(IA),1)/3D0
51558 T3I=SIGN(1D0,EI+1D-6)/2D0
51559 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51561 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51562 CXC(2)=DCMPLX(0D0,0D0)
51563 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51564 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51565 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51566 CXC(6)=DCMPLX(0D0,0D0)
51567 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51568 CXC(8)=DCMPLX(0D0,0D0)
51569 IF( XXC(5).LT.AXMI ) THEN
51574 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51576 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51577 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51578 IDLAM(LKNT,1)=KFCCHI(1)
51581 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51583 XLAM(LKNT)=XLAM(LKNT-1)
51584 IDLAM(LKNT,1)=KFCCHI(1)
51589 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51590 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51591 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51593 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51595 IF( XXC(5).LT.AXMI ) THEN
51600 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51601 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51602 IDLAM(LKNT,1)=KFCCHI(1)
51611 EI=KCHG(IABS(IA),1)/3D0
51612 T3I=SIGN(1D0,EI+1D-6)/2D0
51613 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51615 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51616 CXC(2)=DCMPLX(0D0,0D0)
51617 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51618 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51619 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51620 CXC(6)=DCMPLX(0D0,0D0)
51621 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51622 CXC(8)=DCMPLX(0D0,0D0)
51623 IF( XXC(5).LT.AXMI ) THEN
51628 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51630 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51631 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51632 IDLAM(LKNT,1)=KFCCHI(1)
51635 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51637 XLAM(LKNT)=XLAM(LKNT-1)
51638 IDLAM(LKNT,1)=KFCCHI(1)
51646 C...CHI_2+ -> CHI_1+ + H0_K
51654 XMH=PMAS(ITH(IH),1)
51656 C...NO 3-BODY OPTION
51657 IF(AXMI.GE.AXMJ+XMH) THEN
51659 XL=PYLAMF(XMI2,XMJ2,XMH2)
51660 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
51661 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
51662 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
51663 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
51665 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51666 GLR=DBLE(OLPP*DCONJG(ORPP))
51667 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51668 IDLAM(LKNT,1)=KFCCHI(1)
51669 IDLAM(LKNT,2)=ITH(IH)
51674 C...CHI1 JUMPS TO HERE
51677 C...CHI+_I -> CHI0_J + W+
51682 IF(AXMI.GE.AXMJ+XMW) THEN
51685 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51687 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51688 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
51689 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51690 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
51691 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51692 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51693 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51694 IDLAM(LKNT,1)=KFNCHI(IJ)
51698 ELSEIF(AXMI.GE.AXMJ) THEN
51700 S12MAX=(AXMI-AXMJ)**2
51702 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51704 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51705 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
51706 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51707 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
51708 CXC(5)=DCMPLX(0D0,0D0)
51709 CXC(7)=DCMPLX(0D0,0D0)
51713 T3I=SIGN(1D0,EI+1D-6)/2D0
51715 T3J=SIGN(1D0,EJ+1D-6)/2D0
51716 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51717 & TANW+ZMIXC(IJ,2)*T3J)/SR2
51718 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51719 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
51720 CXC(6)=DCMPLX(0D0,0D0)
51721 CXC(8)=DCMPLX(0D0,0D0)
51726 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51727 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51730 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51731 IF(XXC(5).LT.AXMI) THEN
51733 ELSEIF(XXC(6).LT.AXMI) THEN
51738 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
51739 C...--> 1/(16PI)/M**3*(AEM/XW)**2
51740 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51742 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51743 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51744 IDLAM(LKNT,1)=KFNCHI(IJ)
51747 C...ONLY DECAY CHI+1 -> E+ NU_E
51748 IF( IMSS(12).NE. 0 ) GOTO 260
51749 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51751 XLAM(LKNT)=XLAM(LKNT-1)
51752 IDLAM(LKNT,1)=KFNCHI(IJ)
51757 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51759 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51760 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51762 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51764 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51765 IF(XXC(5).LT.AXMI) THEN
51767 ELSEIF(XXC(6).LT.AXMI) THEN
51772 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51773 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51774 IDLAM(LKNT,1)=KFNCHI(IJ)
51779 C...NOW, DO THE QUARKS
51784 T3I=SIGN(1D0,EI+1D-6)/2D0
51786 T3J=SIGN(1D0,EJ+1D-6)/2D0
51787 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51788 & TANW+ZMIXC(IJ,2)*T3J)
51789 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51790 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
51791 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51792 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51793 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
51794 IF(XXC(5).LT.AXMI) THEN
51797 IF(XXC(6).LT.AXMI) THEN
51802 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51804 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51805 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51806 IDLAM(LKNT,1)=KFNCHI(IJ)
51809 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51811 XLAM(LKNT)=XLAM(LKNT-1)
51812 IDLAM(LKNT,1)=KFNCHI(IJ)
51821 C...CHI+_I -> CHI0_J + H+
51827 IF(AXMI.GE.AXMJ+XMHP) THEN
51829 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
51830 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
51831 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
51832 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
51834 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51835 GLR=DBLE(OLPP*DCONJG(ORPP))
51836 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51837 IDLAM(LKNT,1)=KFNCHI(IJ)
51845 C...2-BODY DECAYS TO FERMION SFERMION
51847 IF(J.GE.7.AND.J.LE.10) GOTO 240
51848 IF(MOD(J,2).EQ.0) THEN
51854 XMSF1=PMAS(PYCOMP(KF1),1)
51855 XMSF2=PMAS(PYCOMP(KF2),1)
51864 IF(MOD(J,2).EQ.0) THEN
51867 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
51868 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
51874 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
51876 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
51881 IF(AXMI.GE.XMF+XMSF1) THEN
51885 XL=PYLAMF(XMI2,XMA2,XMB2)
51886 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
51887 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
51888 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51889 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51891 IF(MOD(J,2).EQ.0) THEN
51901 IF(AXMI.GE.XMF+XMSF2) THEN
51905 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
51906 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
51907 XL=PYLAMF(XMI2,XMA2,XMB2)
51908 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51909 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51911 IF(MOD(J,2).EQ.0) THEN
51921 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
51922 C...A 2-BODY -- 2-BODY CHAIN
51923 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51924 IF(AXMI.GE.XMJ) THEN
51927 S12MAX=(AXMI-AXMJ)**2
51932 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51933 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51936 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51938 CXC(1)=DCMPLX(0D0,0D0)
51939 CXC(3)=DCMPLX(0D0,0D0)
51940 CXC(5)=DCMPLX(0D0,0D0)
51941 CXC(7)=DCMPLX(0D0,0D0)
51942 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51943 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51944 CXC(6)=DCMPLX(0D0,0D0)
51945 CXC(8)=DCMPLX(0D0,0D0)
51946 IF(XXC(5).LT.AXMI) THEN
51948 ELSEIF(XXC(6).LT.AXMI) THEN
51953 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
51954 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51956 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51957 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51958 IDLAM(LKNT,1)=KSUSY1+21
51961 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51963 XLAM(LKNT)=XLAM(LKNT-1)
51964 IDLAM(LKNT,1)=KSUSY1+21
51972 C...R-violating decay modes (SKANDS).
51973 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
51978 XLAM(0)=XLAM(0)+XLAM(I)
51979 IF(XLAM(I).LT.0D0) THEN
51980 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
51981 & (IDLAM(I,J),J=1,3)
51985 IF(XLAM(0).EQ.0D0) THEN
51987 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
51988 WRITE(MSTU(11),*) LKNT
51989 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
51995 C*********************************************************************
51998 C...Used in the calculation of inoi -> inoj + f + ~f.
52002 C...Double precision and integer declarations.
52003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52004 IMPLICIT INTEGER(I-N)
52005 INTEGER PYK,PYCHGE,PYCOMP
52006 C...Parameter statement to help give large particle numbers.
52007 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52008 &KEXCIT=4000000,KDIMEN=5000000)
52010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52011 C COMMON/PYINTS/XXM(20)
52013 COMMON/PYINTC/XXC(10),CXC(8)
52014 SAVE /PYDAT1/,/PYINTC/
52016 C...Local variables.
52017 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52018 DOUBLE PRECISION PYXXZ6,X
52019 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52020 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52021 DOUBLE PRECISION SIJ
52022 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52023 DOUBLE PRECISION OL2
52024 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52027 C...Statement functions.
52028 C...Integral from x to y of (t-a)(b-t) dt.
52029 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
52030 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52031 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
52032 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
52033 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52034 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
52035 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
52036 C...Integral from x to y of (t-a)/(b-t) dt.
52037 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
52038 C...Integral from x to y of 1/(t-a) dt.
52039 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
52047 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
52048 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
52049 &( (X-XM22-S)**2 -4D0*XM22*S ) )
52051 S23MIN=(S23AVE-S23DEL)
52052 S23MAX=(S23AVE+S23DEL)
52069 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
52070 SIJ=2D0*XXC(2)*XXC(4)*S13
52071 IF(XMV.LE.1000D0) THEN
52072 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
52073 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
52074 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
52075 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
52076 IF(XXC(5).LE.10000D0) THEN
52077 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
52078 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
52079 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
52080 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
52081 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
52082 & *(S13-XMV**2)/WPROP2
52087 IF(XXC(6).LE.10000D0) THEN
52088 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
52089 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
52090 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
52091 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
52092 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
52093 & *(S13-XMV**2)/WPROP2
52102 IF(XXC(5).LE.10000D0) THEN
52103 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
52104 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
52105 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
52106 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
52110 IF(XXC(6).LE.10000D0) THEN
52111 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
52112 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
52113 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
52114 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
52119 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
52121 IF(PYXXZ6.LT.0D0) THEN
52122 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
52123 WRITE(MSTU(11),*) (XXC(I),I=1,5)
52124 WRITE(MSTU(11),*) (XXC(I),I=6,10)
52125 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
52126 WRITE(MSTU(11),*) S23MIN,S23MAX
52134 C*********************************************************************
52137 C...Calculates chi0_i -> chi0_j + gamma.
52139 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
52141 C...Double precision and integer declarations.
52142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52143 IMPLICIT INTEGER(I-N)
52144 INTEGER PYK,PYCHGE,PYCOMP
52146 C...Local variables.
52147 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
52148 DOUBLE PRECISION F1,F2
52150 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
52151 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
52152 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
52153 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
52158 C*********************************************************************
52161 C...Calculates the decay rate for ino -> ino + gauge boson.
52163 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
52165 C...Double precision and integer declarations.
52166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52167 IMPLICIT INTEGER(I-N)
52168 INTEGER PYK,PYCHGE,PYCOMP
52170 C...Local variables.
52171 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
52172 DOUBLE PRECISION XL,PYLAMF,C1
52173 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52179 XL=PYLAMF(XMI2,XMJ2,XMV2)
52180 PYX2XG=C1/8D0/XMI3*SQRT(XL)
52181 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
52182 &12D0*GLR*XM1*XM2*XMV2)
52187 C*********************************************************************
52190 C...Calculates the decay rate for ino -> ino + H.
52192 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
52194 C...Double precision and integer declarations.
52195 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52196 IMPLICIT INTEGER(I-N)
52197 INTEGER PYK,PYCHGE,PYCOMP
52199 C...Local variables.
52200 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
52201 DOUBLE PRECISION XL,PYLAMF,C1
52202 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52208 XL=PYLAMF(XMI2,XMJ2,XMV2)
52209 PYX2XH=C1/8D0/XMI3*SQRT(XL)
52210 &*(GX2*(XMI2+XMJ2-XMV2)+
52216 C*********************************************************************
52219 C...Calculates the non-standard decay modes of the Higgs boson.
52221 C...Author: Stephen Mrenna
52222 C...Last Update: April 2001
52223 C......Allow complex values for Z,U, and V
52225 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
52227 C...Double precision and integer declarations.
52228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52229 IMPLICIT INTEGER(I-N)
52230 INTEGER PYK,PYCHGE,PYCOMP
52231 C...Parameter statement to help give large particle numbers.
52232 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52233 &KEXCIT=4000000,KDIMEN=5000000)
52235 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52236 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52237 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52238 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52239 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52240 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52241 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
52243 C...Local variables.
52244 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52245 COMPLEX*16 QIJ,RIJ,F21K,F12K
52247 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
52248 DOUBLE PRECISION XMI2,XMI3,XMJ2
52249 DOUBLE PRECISION PYLAMF,XL,CF,EI
52251 DOUBLE PRECISION TANW,XW,AEM,C1,AS
52252 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
52253 DOUBLE PRECISION XLAM(0:400)
52254 INTEGER IDLAM(400,3)
52255 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
52257 INTEGER KFNCHI(4),KFCCHI(2)
52258 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
52259 DOUBLE PRECISION SR2
52260 DOUBLE PRECISION BETA,ALFA
52261 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
52262 DOUBLE PRECISION PYALEM
52263 DOUBLE PRECISION AL,AR,ALR
52264 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
52265 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
52266 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
52267 DATA ITH/25,35,36,37/
52268 DATA ETAH/1D0,1D0,-1D0/
52269 DATA SR2/1.4142136D0/
52270 DATA KFNCHI/1000022,1000023,1000025,1000035/
52271 DATA KFCCHI/1000024,1000037/
52273 C...COUNT THE NUMBER OF DECAY MODES
52280 TANW = SQRT(XW/(1D0-XW))
52283 C...1 - 4 DEPENDING ON Higgs species.
52285 IF(KFIN.EQ.ITH(2)) IH=2
52286 IF(KFIN.EQ.ITH(3)) IH=3
52287 IF(KFIN.EQ.ITH(4)) IH=4
52310 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52315 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52316 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52321 IF(IH.EQ.4) GOTO 220
52323 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52324 C...H0_K -> CHI0_I + CHI0_J
52337 IF(AXMI.GE.AXMJ+AXMK) THEN
52339 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
52340 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
52341 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
52342 & ZMIXC(IJ,3)*ZMIXC(IK,1))
52343 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
52344 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
52345 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
52346 & ZMIXC(IJ,4)*ZMIXC(IK,1))
52347 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
52348 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
52349 C...SIGN OF MASSES I,J
52351 GX2=ABS(F12K)**2+ABS(F21K)**2
52352 GLR=DBLE(F12K*DCONJG(F21K))
52353 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52354 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
52355 IDLAM(LKNT,1)=KFNCHI(IJ)
52356 IDLAM(LKNT,2)=KFNCHI(IK)
52362 C...H0_K -> CHI+_I CHI-_J
52369 IF(AXMI.GE.AXMJ+AXMK) THEN
52371 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
52372 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
52373 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
52374 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
52375 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52376 GLR=DBLE(OLPP*DCONJG(ORPP))
52378 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52379 IDLAM(LKNT,1)=KFCCHI(IJ)
52380 IDLAM(LKNT,2)=-KFCCHI(IK)
52386 C...HIGGS TO SFERMION SFERMION
52388 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
52390 XMJL=PMAS(PYCOMP(IJ),1)
52391 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
52392 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
52395 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52402 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
52403 & XMF**2/XMW*SINA/CBETA
52404 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
52405 & XMF**2/XMW*SINA/CBETA
52407 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52409 ELSEIF(IFL.EQ.15) THEN
52410 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52416 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
52417 & XMF**2/XMW*COSA/SBETA
52418 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
52419 & XMF**2/XMW*COSA/SBETA
52421 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
52428 ELSEIF(IH.EQ.2) THEN
52430 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
52431 & XMF**2/XMW*COSA/CBETA
52432 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52433 & XMF**2/XMW*COSA/CBETA
52435 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52437 ELSEIF(IFL.EQ.15) THEN
52438 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52444 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
52445 & XMF**2/XMW*SINA/SBETA
52446 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52447 & XMF**2/XMW*SINA/SBETA
52449 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
52456 ELSEIF(IH.EQ.3) THEN
52462 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
52463 ELSEIF(IFL.EQ.15) THEN
52464 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
52468 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
52472 IF(IH.EQ.3) GOTO 180
52476 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
52483 IF(AXMI.GE.2D0*XMJ) THEN
52485 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52487 & +2D0*GHLR*ALR)**2
52493 IF(AXMI.GE.2D0*XMJR) THEN
52497 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
52500 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52501 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52503 & +2D0*GHLR*ALR)**2
52504 IDLAM(LKNT,1)=IJ+KSUSY1
52505 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52510 IF(AXMI.GE.XMJL+XMJR) THEN
52512 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
52513 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
52514 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
52517 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
52518 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52519 & (GHLL*AL+GHRR*AR)**2
52521 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52525 IDLAM(LKNT,2)=IJ+KSUSY1
52527 XLAM(LKNT)=XLAM(LKNT-1)
52537 C...H+ -> CHI+_I + CHI0_J
52545 IF(AXMI.GE.AXMJ+AXMK) THEN
52547 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
52548 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
52549 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
52550 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
52551 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52552 GLR=DBLE(OLPP*DCONJG(ORPP))
52553 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
52554 IDLAM(LKNT,1)=KFNCHI(IJ)
52555 IDLAM(LKNT,2)=KFCCHI(IK)
52561 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
52562 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
52568 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52569 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52570 IF(XMI.GE.XM1+XM2) THEN
52571 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52573 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52574 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
52575 IDLAM(LKNT,1)=KSUSY1+6
52576 IDLAM(LKNT,2)=-(KSUSY1+5)
52581 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52582 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52583 IF(XMI.GE.XM1+XM2) THEN
52584 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52586 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52587 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
52588 IDLAM(LKNT,1)=KSUSY2+6
52589 IDLAM(LKNT,2)=-(KSUSY1+5)
52594 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52595 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52596 IF(XMI.GE.XM1+XM2) THEN
52597 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52599 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52600 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
52601 IDLAM(LKNT,1)=KSUSY1+6
52602 IDLAM(LKNT,2)=-(KSUSY2+5)
52607 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52608 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52609 IF(XMI.GE.XM1+XM2) THEN
52610 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52612 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52613 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
52614 IDLAM(LKNT,1)=KSUSY2+6
52615 IDLAM(LKNT,2)=-(KSUSY2+5)
52620 GL=-XMW/SR2*SIN(2D0*BETA)
52622 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52623 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52624 IF(XMI.GE.XM1+XM2) THEN
52625 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52627 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52628 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52629 IDLAM(LKNT,2)=KSUSY1+IJ+1
52637 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52638 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52639 IF(XMI.GE.XM1+XM2) THEN
52640 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52642 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52643 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52644 IDLAM(LKNT,2)=KSUSY1+IJ+1
52649 C...H+ -> TAU1 NUTAUL
52650 XM1=PMAS(PYCOMP(KSUSY1+15),1)
52651 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52652 IF(XMI.GE.XM1+XM2) THEN
52653 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52655 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
52656 IDLAM(LKNT,1)=-(KSUSY1+15)
52657 IDLAM(LKNT,2)= KSUSY1+16
52661 C...H+ -> TAU2 NUTAUL
52662 XM1=PMAS(PYCOMP(KSUSY2+15),1)
52663 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52664 IF(XMI.GE.XM1+XM2) THEN
52665 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52667 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
52668 IDLAM(LKNT,1)=-(KSUSY2+15)
52669 IDLAM(LKNT,2)= KSUSY1+16
52677 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
52678 XLAM(0)=XLAM(0)+XLAM(I)
52680 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52685 C*********************************************************************
52688 C...Calculates the decay rate for a Higgs to an ino pair.
52690 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
52692 C...Double precision and integer declarations.
52693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52694 IMPLICIT INTEGER(I-N)
52695 INTEGER PYK,PYCHGE,PYCOMP
52697 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52700 C...Local variables.
52701 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
52702 DOUBLE PRECISION XL,PYLAMF,C1
52703 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
52709 XL=PYLAMF(XMI2,XMJ2,XMK2)
52710 PYH2XX=C1/4D0/XMI3*SQRT(XL)
52711 &*(GX2*(XMI2-XMJ2-XMK2)-
52713 IF(PYH2XX.LT.0D0) PYH2XX=0D0
52718 C*********************************************************************
52721 C...Integration by adaptive Gaussian quadrature.
52722 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52724 FUNCTION PYGAUS(F, A, B, EPS)
52726 C...Double precision and integer declarations.
52727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52728 IMPLICIT INTEGER(I-N)
52729 INTEGER PYK,PYCHGE,PYCOMP
52731 C...Local declarations.
52733 DOUBLE PRECISION F,W(12), X(12)
52734 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52735 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52736 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52737 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52738 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52739 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52740 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52741 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52742 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52743 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52744 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52745 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52747 C...The Gaussian quadrature algorithm.
52749 IF(B .EQ. A) GOTO 140
52750 CONST = 5D-3 / ABS(B-A)
52761 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52766 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52769 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52771 IF(BB .NE. B) GOTO 100
52774 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52776 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
52785 C*********************************************************************
52788 C...Integration by adaptive Gaussian quadrature.
52789 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52790 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
52792 FUNCTION PYGAU2(F, A, B, EPS)
52794 C...Double precision and integer declarations.
52795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52796 IMPLICIT INTEGER(I-N)
52797 INTEGER PYK,PYCHGE,PYCOMP
52799 C...Local declarations.
52801 DOUBLE PRECISION F,W(12), X(12)
52802 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52803 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52804 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52805 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52806 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52807 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52808 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52809 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52810 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52811 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52812 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52813 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52815 C...The Gaussian quadrature algorithm.
52817 IF(B .EQ. A) GOTO 140
52818 CONST = 5D-3 / ABS(B-A)
52829 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52834 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52837 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52839 IF(BB .NE. B) GOTO 100
52842 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52844 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
52853 C*********************************************************************
52856 C...Simpson formula for an integral.
52858 FUNCTION PYSIMP(Y,X0,X1,N)
52860 C...Double precision and integer declarations.
52861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52862 IMPLICIT INTEGER(I-N)
52863 INTEGER PYK,PYCHGE,PYCOMP
52865 C...Local variables.
52866 DOUBLE PRECISION Y,X0,X1,H,S
52872 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
52879 C*********************************************************************
52882 C...The standard lambda function.
52884 FUNCTION PYLAMF(X,Y,Z)
52886 C...Double precision and integer declarations.
52887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52888 IMPLICIT INTEGER(I-N)
52889 INTEGER PYK,PYCHGE,PYCOMP
52891 C...Local variables.
52892 DOUBLE PRECISION PYLAMF,X,Y,Z
52894 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
52895 IF(PYLAMF.LT.0D0) PYLAMF=0D0
52900 C*********************************************************************
52903 C...Generates 3-body decays of gauginos.
52905 SUBROUTINE PYTBDY(IDIN)
52907 C...Double precision and integer declarations.
52908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52909 IMPLICIT INTEGER(I-N)
52910 INTEGER PYK,PYCHGE,PYCOMP
52911 C...Parameter statement to help give large particle numbers.
52912 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52913 &KEXCIT=4000000,KDIMEN=5000000)
52915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52918 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52919 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52920 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52921 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52922 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
52923 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
52925 C...Local variables.
52926 DOUBLE PRECISION XM(5)
52927 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
52928 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
52929 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
52930 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
52931 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
52932 DOUBLE PRECISION CPHI1,SPHI1
52933 DOUBLE PRECISION S23DEL,EPS
52934 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
52935 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
52936 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
52938 DATA INOID/22,23,25,35/
52949 S12MIN=(XM(1)+XM(2))**2
52950 S12MAX=(XM(5)-XM(3))**2
52951 YJACO1=S12MAX-S12MIN
52953 C...Initialize some parameters
52965 C...Mrenna: check that we are indeed decaying a SUSY particle
52966 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
52970 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
52971 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
52973 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
52974 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
52975 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
52976 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
52979 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
52980 T3I=SIGN(1D0,EI+1D-6)/2D0
52983 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
52985 ELSEIF(IZID1*IZID2.NE.0) THEN
52987 GMMZ=PMAS(23,1)*PMAS(23,2)
52989 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
52990 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
52992 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
52993 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
52995 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
52997 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
52999 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53000 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53001 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53002 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53003 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53005 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53007 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53009 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53011 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53012 IF(IZID1.NE.0) THEN
53013 XM1M2=SMZ(IZID1)*SMW(IWID2)
53017 XM1M2=SMZ(IZID2)*SMW(IWID1)
53020 RT2I = 1D0/SQRT(2D0)
53022 GMMZ=PMAS(24,1)*PMAS(24,2)
53024 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53025 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53028 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53030 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
53031 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
53032 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
53033 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
53034 EJ=KCHG(IABS(JA),1)/3D0
53035 T3J=SIGN(1D0,EJ+1D-6)/2D0
53036 QRLS=DCMPLX(0D0,0D0)
53042 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
53043 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53044 IF(MOD(IA,2).EQ.0) THEN
53045 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
53046 & TANW+ZMIXC(IZID2,2)*T3I)
53047 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53048 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
53050 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
53051 & TANW+ZMIXC(IZID2,2)*T3J)
53052 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53053 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
53055 ELSEIF(IWID1*IWID2.NE.0) THEN
53058 XM1M2=SMW(IWID1)*SMW(IWID2)
53060 GMMZ=PMAS(23,1)*PMAS(23,2)
53062 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53063 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53064 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
53065 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
53067 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
53068 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
53069 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
53070 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
53071 QRLS=-DCMPLX(EI/XW1)*ORPP
53072 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53073 QRRS=-DCMPLX(EI/XW1)*OLPP
53074 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53075 IF(MOD(IA,2).EQ.0) THEN
53076 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
53077 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
53079 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
53080 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
53082 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
53089 IF(ISKIP.NE.0) THEN
53092 S12=S12MIN+YJACO1*(KT-1)/99
53093 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53094 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53095 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53096 & -(2D0*XM(1)*XM(2))**2
53097 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53098 & -(2D0*XM(3)*XM(5))**2
53101 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53103 S23MIN=S23AVE-S23DEL
53104 S23MAX=S23AVE+S23DEL
53105 YJACO2=S23MAX-S23MIN
53108 S23=S23MIN+YJACO2*(KS-1)/99
53111 WU2 = (UH-ZM12)*(UH-ZM22)
53112 WT2 = (TH-ZM12)*(TH-ZM22)
53114 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53115 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53116 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53117 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53118 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53119 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53120 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53121 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
53122 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53123 IF(WT0.GT.WTMAX) WTMAX=WT0
53133 BX=S12MIN+0.5D0*YJACO1
53136 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
53144 C...SOLVE FOR F1 AND F2
53145 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53146 &-(2D0*XM(1)*XM(2))**2
53147 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53148 &-(2D0*XM(3)*XM(5))**2
53151 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53153 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53154 &-(2D0*XM(1)*XM(2))**2
53155 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53156 &-(2D0*XM(3)*XM(5))**2
53159 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53162 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
53163 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
53169 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53170 & -(2D0*XM(1)*XM(2))**2
53171 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53172 & -(2D0*XM(3)*XM(5))**2
53175 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53182 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53183 & -(2D0*XM(1)*XM(2))**2
53184 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53185 & -(2D0*XM(3)*XM(5))**2
53188 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53193 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
53203 180 S12=S12MIN+PYR(0)*YJACO1
53206 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53207 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53208 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53209 &-(2D0*XM(1)*XM(2))**2
53210 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53211 &-(2D0*XM(3)*XM(5))**2
53214 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53216 S23MIN=S23AVE-S23DEL
53217 S23MAX=S23AVE+S23DEL
53218 YJACO2=S23MAX-S23MIN
53219 S23=S23MIN+PYR(0)*YJACO2
53221 C...CHECK THE SAMPLING
53222 IF(IKNT.GT.100) THEN
53223 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
53226 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
53228 IF(ISKIP.EQ.0) GOTO 190
53234 WU2 = (UH-ZM12)*(UH-ZM22)
53235 WT2 = (TH-ZM12)*(TH-ZM22)
53237 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53238 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53240 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53241 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53242 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53243 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53244 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
53245 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
53246 c &/DCMPLX(TH-XML2)
53247 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
53248 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
53249 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
53250 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53251 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
53252 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53254 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
53255 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
53257 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
53258 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
53260 P1=SQRT(D1*D1-XM(1)**2)
53261 P2=SQRT(D2*D2-XM(2)**2)
53262 P3=SQRT(D3*D3-XM(3)**2)
53263 CTHE1=2D0*PYR(0)-1D0
53264 ANG1=2D0*PYR(0)*PARU(1)
53268 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53270 P(N+1,1)=P1*STHE1*CPHI1
53271 P(N+1,2)=P1*STHE1*SPHI1
53276 ANG3=2D0*PYR(0)*PARU(1)
53279 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
53281 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53283 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
53284 &+P3*STHE3*SPHI3*SPHI1
53285 &+P3*CTHE3*STHE1*CPHI1
53286 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
53287 &-P3*STHE3*SPHI3*CPHI1
53288 &+P3*CTHE3*STHE1*SPHI1
53289 P(N+3,3)=P3*STHE3*CPHI3*STHE1
53294 P(N+2,I)=-P(N+1,I)-P(N+3,I)
53302 C*********************************************************************
53305 C...Finds the s-hat dependent eigenvalues of the inverse propagator
53306 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
53307 C...phase space generation. Extended to include techni-a meson, and
53308 C...to return the width.
53310 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
53312 C...Double precision and integer declarations.
53313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53314 IMPLICIT INTEGER(I-N)
53315 INTEGER PYK,PYCHGE,PYCOMP
53316 C...Parameter statement to help give large particle numbers.
53317 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53318 &KEXCIT=4000000,KDIMEN=5000000)
53320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53322 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53323 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53324 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
53326 C...Local variables.
53327 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
53328 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
53329 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
53336 SINW=MIN(SQRT(PARU(102)),1D0)
53337 COSW=SQRT(1D0-SINW**2)
53339 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
53340 QUPD=2D0*RTCM(2)-1D0
53342 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
53343 FAR=SQRT(AEM/ALPRHT)
53347 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
53360 AR(2,2) = SH-PMAS(23,1)**2
53361 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
53362 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
53363 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
53384 CALL PYWIDT(23,SH,WDTP,WDTE)
53385 AT(2,2) = WDTP(0)*SHR
53386 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
53387 AT(3,3) = WDTP(0)*SHR
53388 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
53389 AT(4,4) = WDTP(0)*SHR
53390 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
53391 AT(5,5) = WDTP(0)*SHR
53395 AR(1,1) = SH-PMAS(24,1)**2
53396 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
53397 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
53404 CALL PYWIDT(24,SH,WDTP,WDTE)
53405 AT(1,1) = WDTP(0)*SHR
53406 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
53407 AT(2,2) = WDTP(0)*SHR
53408 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
53409 AT(3,3) = WDTP(0)*SHR
53412 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
53417 WX(I)=SQRT(ABS(SH-WR(I)))
53419 IF(WR(I).LT.SXMN) THEN
53430 C*********************************************************************
53433 C...Finds eigenvalues of a general complex matrix
53435 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
53436 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
53437 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
53438 C OF A COMPLEX GENERAL MATRIX.
53442 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
53443 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53444 C DIMENSION STATEMENT.
53446 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
53448 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53449 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
53451 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
53452 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
53453 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
53457 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53458 C RESPECTIVELY, OF THE EIGENVALUES.
53460 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53461 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
53463 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
53464 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
53465 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
53467 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
53469 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53470 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53472 C THIS VERSION DATED AUGUST 1983.
53475 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
53477 INTEGER N,NM,IS1,IS2,IERR,MATZ
53478 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53479 X FV1(5),FV2(5),FV3(5)
53480 IF (N .LE. NM) GOTO 100
53484 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
53485 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
53486 IF (MATZ .NE. 0) GOTO 110
53487 C .......... FIND EIGENVALUES ONLY ..........
53488 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
53490 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
53491 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
53492 IF (IERR .NE. 0) GOTO 120
53493 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
53497 C*********************************************************************
53500 C...Auxiliary to PYEICG.
53502 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53503 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
53505 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
53506 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53507 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53509 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
53510 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
53514 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53515 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53516 C DIMENSION STATEMENT.
53518 C N IS THE ORDER OF THE MATRIX.
53520 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53521 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53522 C SET LOW=1, IGH=N.
53524 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53525 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53526 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
53527 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
53528 C THE REDUCTION BY CORTH, IF PERFORMED.
53532 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
53533 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
53534 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
53535 C EIGENVECTORS IS TO BE PERFORMED.
53537 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53538 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53539 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53540 C FOR INDICES IERR+1,...,N.
53543 C ZERO FOR NORMAL RETURN,
53544 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53545 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53547 C CALLS PYCDIV FOR COMPLEX DIVISION.
53548 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53549 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53551 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53552 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53554 C THIS VERSION DATED AUGUST 1983.
53557 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
53559 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
53560 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
53561 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53565 IF (LOW .EQ. IGH) GOTO 130
53566 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53571 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
53572 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53573 YR = HR(I,I-1) / NORM
53574 YI = HI(I,I-1) / NORM
53579 SI = YR * HI(I,J) - YI * HR(I,J)
53580 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53585 SI = YR * HI(J,I) + YI * HR(J,I)
53586 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53591 C .......... STORE ROOTS ISOLATED BY CBAL ..........
53592 130 DO 140 I = 1, N
53593 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53602 C .......... SEARCH FOR NEXT EIGENVALUE ..........
53603 150 IF (EN .LT. LOW) GOTO 320
53606 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53607 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
53608 160 DO 170 LL = LOW, EN
53610 IF (L .EQ. LOW) GOTO 180
53611 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53612 X + DABS(HR(L,L)) + DABS(HI(L,L))
53613 TST2 = TST1 + DABS(HR(L,L-1))
53614 IF (TST2 .EQ. TST1) GOTO 180
53616 C .......... FORM SHIFT ..........
53617 180 IF (L .EQ. EN) GOTO 300
53618 IF (ITN .EQ. 0) GOTO 310
53619 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
53622 XR = HR(ENM1,EN) * HR(EN,ENM1)
53623 XI = HI(ENM1,EN) * HR(EN,ENM1)
53624 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
53625 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53626 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53627 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53628 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
53631 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53635 C .......... FORM EXCEPTIONAL SHIFT ..........
53636 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53639 210 DO 220 I = LOW, EN
53640 HR(I,I) = HR(I,I) - SR
53641 HI(I,I) = HI(I,I) - SI
53648 C .......... REDUCE TO TRIANGLE (ROWS) ..........
53654 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53655 XR = HR(I-1,I-1) / NORM
53657 XI = HI(I-1,I-1) / NORM
53660 HI(I-1,I-1) = 0.0D0
53661 HI(I,I-1) = SR / NORM
53668 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53669 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53670 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53671 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53677 IF (SI .EQ. 0.0D0) GOTO 250
53678 NORM = PYTHAG(HR(EN,EN),SI)
53679 SR = HR(EN,EN) / NORM
53683 C .......... INVERSE OPERATION (COLUMNS) ..........
53684 250 DO 280 J = LP1, EN
53693 IF (I .EQ. J) GOTO 260
53695 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
53696 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
53697 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
53698 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
53703 IF (SI .EQ. 0.0D0) GOTO 160
53708 HR(I,EN) = SR * YR - SI * YI
53709 HI(I,EN) = SR * YI + SI * YR
53713 C .......... A ROOT FOUND ..........
53714 300 WR(EN) = HR(EN,EN) + TR
53715 WI(EN) = HI(EN,EN) + TI
53718 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
53719 C CONVERGED AFTER 30*N ITERATIONS ..........
53724 C*********************************************************************
53727 C...Auxiliary to PYEICG.
53729 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53730 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
53732 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
53733 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53734 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53736 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
53737 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
53738 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
53739 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
53740 C THIS GENERAL MATRIX TO HESSENBERG FORM.
53744 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53745 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53746 C DIMENSION STATEMENT.
53748 C N IS THE ORDER OF THE MATRIX.
53750 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53751 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53752 C SET LOW=1, IGH=N.
53754 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
53755 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
53756 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
53757 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
53758 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
53760 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53761 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53762 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
53763 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
53764 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
53765 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
53770 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
53771 C HAVE BEEN DESTROYED.
53773 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53774 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53775 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53776 C FOR INDICES IERR+1,...,N.
53778 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53779 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
53780 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
53781 C THE EIGENVECTORS HAS BEEN FOUND.
53784 C ZERO FOR NORMAL RETURN,
53785 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53786 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53788 C CALLS PYCDIV FOR COMPLEX DIVISION.
53789 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53790 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53792 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53793 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53795 C THIS VERSION DATED OCTOBER 1989.
53797 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
53798 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
53801 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
53803 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
53804 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
53805 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53807 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53811 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
53820 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
53821 C FROM THE INFORMATION LEFT BY CORTH ..........
53822 IEND = IGH - LOW - 1
53823 IF (IEND.LT.0) GOTO 220
53824 IF (IEND.EQ.0) GOTO 170
53825 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
53826 DO 160 II = 1, IEND
53828 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
53829 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
53830 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
53831 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
53834 DO 120 K = IP1, IGH
53835 ORTR(K) = HR(K,I-1)
53836 ORTI(K) = HI(K,I-1)
53844 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
53845 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
53852 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
53853 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
53859 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53864 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
53865 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53866 YR = HR(I,I-1) / NORM
53867 YI = HI(I,I-1) / NORM
53872 SI = YR * HI(I,J) - YI * HR(I,J)
53873 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53878 SI = YR * HI(J,I) + YI * HR(J,I)
53879 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53883 DO 200 J = LOW, IGH
53884 SI = YR * ZI(J,I) + YI * ZR(J,I)
53885 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
53890 C .......... STORE ROOTS ISOLATED BY CBAL ..........
53891 220 DO 230 I = 1, N
53892 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
53901 C .......... SEARCH FOR NEXT EIGENVALUE ..........
53902 240 IF (EN .LT. LOW) GOTO 430
53905 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53906 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
53907 250 DO 260 LL = LOW, EN
53909 IF (L .EQ. LOW) GOTO 270
53910 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53911 X + DABS(HR(L,L)) + DABS(HI(L,L))
53912 TST2 = TST1 + DABS(HR(L,L-1))
53913 IF (TST2 .EQ. TST1) GOTO 270
53915 C .......... FORM SHIFT ..........
53916 270 IF (L .EQ. EN) GOTO 420
53917 IF (ITN .EQ. 0) GOTO 550
53918 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
53921 XR = HR(ENM1,EN) * HR(EN,ENM1)
53922 XI = HI(ENM1,EN) * HR(EN,ENM1)
53923 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
53924 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53925 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53926 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53927 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
53930 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53934 C .......... FORM EXCEPTIONAL SHIFT ..........
53935 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53938 300 DO 310 I = LOW, EN
53939 HR(I,I) = HR(I,I) - SR
53940 HI(I,I) = HI(I,I) - SI
53947 C .......... REDUCE TO TRIANGLE (ROWS) ..........
53953 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53954 XR = HR(I-1,I-1) / NORM
53956 XI = HI(I-1,I-1) / NORM
53959 HI(I-1,I-1) = 0.0D0
53960 HI(I,I-1) = SR / NORM
53967 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53968 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53969 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53970 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53976 IF (SI .EQ. 0.0D0) GOTO 350
53977 NORM = PYTHAG(HR(EN,EN),SI)
53978 SR = HR(EN,EN) / NORM
53982 IF (EN .EQ. N) GOTO 350
53988 HR(EN,J) = SR * YR + SI * YI
53989 HI(EN,J) = SR * YI - SI * YR
53991 C .......... INVERSE OPERATION (COLUMNS) ..........
53992 350 DO 390 J = LP1, EN
54001 IF (I .EQ. J) GOTO 360
54003 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54004 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54005 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54006 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54009 DO 380 I = LOW, IGH
54014 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54015 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54016 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54017 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54022 IF (SI .EQ. 0.0D0) GOTO 250
54027 HR(I,EN) = SR * YR - SI * YI
54028 HI(I,EN) = SR * YI + SI * YR
54031 DO 410 I = LOW, IGH
54034 ZR(I,EN) = SR * YR - SI * YI
54035 ZI(I,EN) = SR * YI + SI * YR
54039 C .......... A ROOT FOUND ..........
54040 420 HR(EN,EN) = HR(EN,EN) + TR
54042 HI(EN,EN) = HI(EN,EN) + TI
54046 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
54047 C VECTORS OF UPPER TRIANGULAR FORM ..........
54053 TR = DABS(HR(I,J)) + DABS(HI(I,J))
54054 IF (TR .GT. NORM) NORM = TR
54057 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
54058 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
54066 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
54067 DO 490 II = 1, ENM1
54074 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
54075 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
54080 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
54083 460 YR = 0.01D0 * YR
54085 IF (TST2 .GT. TST1) GOTO 460
54087 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
54088 C .......... OVERFLOW CONTROL ..........
54089 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
54090 IF (TR .EQ. 0.0D0) GOTO 490
54092 TST2 = TST1 + 1.0D0/TST1
54093 IF (TST2 .GT. TST1) GOTO 490
54095 HR(J,EN) = HR(J,EN)/TR
54096 HI(J,EN) = HI(J,EN)/TR
54102 C .......... END BACKSUBSTITUTION ..........
54103 C .......... VECTORS OF ISOLATED ROOTS ..........
54105 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
54113 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
54114 C VECTORS OF ORIGINAL FULL MATRIX.
54115 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
54120 DO 540 I = LOW, IGH
54125 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
54126 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
54134 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
54135 C CONVERGED AFTER 30*N ITERATIONS ..........
54140 C*********************************************************************
54143 C...Auxiliary to PYCMQR
54145 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
54148 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
54150 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
54151 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
54153 S = DABS(BR) + DABS(BI)
54158 S = BRS**2 + BIS**2
54159 CR = (ARS*BRS + AIS*BIS)/S
54160 CI = (AIS*BRS - ARS*BIS)/S
54164 C*********************************************************************
54167 C...Auxiliary to PYCMQR
54169 C (YR,YI) = COMPLEX DSQRT(XR,XI)
54170 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
54173 SUBROUTINE PYCSRT(XR,XI,YR,YI)
54175 DOUBLE PRECISION XR,XI,YR,YI
54176 DOUBLE PRECISION S,TR,TI,PYTHAG
54180 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
54181 IF (TR .GE. 0.0D0) YR = S
54182 IF (TI .LT. 0.0D0) S = -S
54183 IF (TR .LE. 0.0D0) YI = S
54184 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
54185 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
54189 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
54190 DOUBLE PRECISION A,B
54192 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
54194 DOUBLE PRECISION P,R,S,T,U
54195 P = DMAX1(DABS(A),DABS(B))
54196 IF (P .EQ. 0.0D0) GOTO 110
54197 R = (DMIN1(DABS(A),DABS(B))/P)**2
54200 IF (T .EQ. 4.0D0) GOTO 110
54202 U = 1.0D0 + 2.0D0*S
54210 C*********************************************************************
54213 C...Auxiliary to PYEICG
54215 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54216 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
54217 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54218 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54220 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
54221 C EIGENVALUES WHENEVER POSSIBLE.
54225 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54226 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54227 C DIMENSION STATEMENT.
54229 C N IS THE ORDER OF THE MATRIX.
54231 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54232 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
54236 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54237 C RESPECTIVELY, OF THE BALANCED MATRIX.
54239 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
54240 C ARE EQUAL TO ZERO IF
54241 C (1) I IS GREATER THAN J AND
54242 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
54244 C SCALE CONTAINS INFORMATION DETERMINING THE
54245 C PERMUTATIONS AND SCALING FACTORS USED.
54247 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
54248 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
54249 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
54250 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
54251 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
54252 C = D(J,J) J = LOW,...,IGH
54253 C = P(J) J = IGH+1,...,N.
54254 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
54257 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
54259 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
54260 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
54261 C K,L HAVE BEEN REVERSED.)
54263 C ARITHMETIC IS REAL THROUGHOUT.
54265 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54266 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54268 C THIS VERSION DATED AUGUST 1983.
54271 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
54273 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
54274 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
54275 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
54284 C .......... IN-LINE PROCEDURE FOR ROW AND
54285 C COLUMN EXCHANGE ..........
54287 IF (J .EQ. M) GOTO 130
54307 130 IF(IEXC.EQ.1) GOTO 140
54308 IF(IEXC.EQ.2) GOTO 180
54309 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
54310 C AND PUSH THEM DOWN ..........
54311 140 IF (L .EQ. 1) GOTO 320
54313 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
54314 150 DO 170 JJ = 1, L
54318 IF (I .EQ. J) GOTO 160
54319 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
54328 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
54329 C AND PUSH THEM LEFT ..........
54332 190 DO 210 J = K, L
54335 IF (I .EQ. J) GOTO 200
54336 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
54343 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
54345 220 SCALE(I) = 1.0D0
54346 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
54347 230 NOCONV = .FALSE.
54354 IF (J .EQ. I) GOTO 240
54355 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
54356 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
54358 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
54359 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
54363 250 IF (C .GE. G) GOTO 260
54368 270 IF (C .LT. G) GOTO 280
54372 C .......... NOW BALANCE ..........
54373 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
54375 SCALE(I) = SCALE(I) * F
54379 AR(I,J) = AR(I,J) * G
54380 AI(I,J) = AI(I,J) * G
54384 AR(J,I) = AR(J,I) * F
54385 AI(J,I) = AI(J,I) * F
54390 IF (NOCONV) GOTO 230
54397 C*********************************************************************
54400 C...Auxiliary to PYEICG.
54402 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54403 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
54404 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54405 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54407 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
54408 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
54409 C BALANCED MATRIX DETERMINED BY CBAL.
54413 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54414 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54415 C DIMENSION STATEMENT.
54417 C N IS THE ORDER OF THE MATRIX.
54419 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
54421 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
54422 C AND SCALING FACTORS USED BY CBAL.
54424 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
54426 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54427 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
54428 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
54432 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54433 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
54434 C IN THEIR FIRST M COLUMNS.
54436 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54437 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54439 C THIS VERSION DATED AUGUST 1983.
54442 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
54444 INTEGER I,J,K,M,N,II,NM,IGH,LOW
54445 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
54448 IF (M .EQ. 0) GOTO 150
54449 IF (IGH .EQ. LOW) GOTO 120
54451 DO 110 I = LOW, IGH
54453 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
54454 C IF THE FOREGOING STATEMENT IS REPLACED BY
54455 C S=1.0D0/SCALE(I). ..........
54457 ZR(I,J) = ZR(I,J) * S
54458 ZI(I,J) = ZI(I,J) * S
54462 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
54463 C IGH+1 STEP 1 UNTIL N DO -- ..........
54464 120 DO 140 II = 1, N
54466 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
54467 IF (I .LT. LOW) I = LOW - II
54469 IF (K .EQ. I) GOTO 140
54485 C*********************************************************************
54488 C...Auxiliary to PYEICG.
54490 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
54491 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
54492 C BY MARTIN AND WILKINSON.
54493 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
54495 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
54496 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
54497 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
54498 C UNITARY SIMILARITY TRANSFORMATIONS.
54502 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54503 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54504 C DIMENSION STATEMENT.
54506 C N IS THE ORDER OF THE MATRIX.
54508 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
54509 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
54510 C SET LOW=1, IGH=N.
54512 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54513 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
54517 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54518 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
54519 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
54520 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
54521 C HESSENBERG MATRIX.
54523 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
54524 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
54526 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
54528 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54529 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54531 C THIS VERSION DATED AUGUST 1983.
54534 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
54536 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
54537 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
54538 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
54542 IF (LA .LT. KP1) GOTO 210
54549 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
54551 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
54553 IF (SCALE .EQ. 0.0D0) GOTO 200
54555 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54558 ORTR(I) = AR(I,M-1) / SCALE
54559 ORTI(I) = AI(I,M-1) / SCALE
54560 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
54564 F = PYTHAG(ORTR(M),ORTI(M))
54565 IF (F .EQ. 0.0D0) GOTO 120
54568 ORTR(M) = (1.0D0 + G) * ORTR(M)
54569 ORTI(M) = (1.0D0 + G) * ORTI(M)
54574 C .......... FORM (I-(U*UT)/H) * A ..........
54575 130 DO 160 J = M, N
54578 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54581 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
54582 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
54589 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
54590 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
54594 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
54598 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
54601 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
54602 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
54609 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
54610 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
54615 ORTR(M) = SCALE * ORTR(M)
54616 ORTI(M) = SCALE * ORTI(M)
54617 AR(M,M-1) = -G * AR(M,M-1)
54618 AI(M,M-1) = -G * AI(M,M-1)
54624 C*********************************************************************
54627 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54630 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
54632 INTEGER N,NP,INDX(N)
54634 COMPLEX*16 A(NP,NP)
54635 PARAMETER (TINY=1.0D-20)
54637 REAL*8 AAMAX,VV(6),DUM
54638 COMPLEX*16 SUM,DUMC
54644 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
54646 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
54653 SUM=SUM-A(I,K)*A(K,J)
54661 SUM=SUM-A(I,K)*A(K,J)
54665 IF (DUM.GE.AAMAX) THEN
54680 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
54683 A(I,J)=A(I,J)/A(J,J)
54691 C*********************************************************************
54694 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54697 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
54699 INTEGER N,NP,INDX(N)
54700 COMPLEX*16 A(NP,NP),B(N)
54711 SUM=SUM-A(I,J)*B(J)
54713 ELSE IF (ABS(SUM).NE.0D0) THEN
54721 SUM=SUM-A(I,J)*B(J)
54728 C***********************************************************************
54731 C...Calculates full and partial widths of resonances.
54732 C....copy of PYWIDT, used for techniparticle widths
54734 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
54736 C...Double precision and integer declarations.
54737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54738 IMPLICIT INTEGER(I-N)
54739 INTEGER PYK,PYCHGE,PYCOMP
54740 C...Parameter statement to help give large particle numbers.
54741 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54742 &KEXCIT=4000000,KDIMEN=5000000)
54744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54746 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54747 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54748 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54749 COMMON/PYINT1/MINT(400),VINT(400)
54750 COMMON/PYINT4/MWID(500),WIDS(500,5)
54751 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54752 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54753 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
54754 &/PYINT4/,/PYMSSM/,/PYTCSM/
54755 C...Local arrays and saved variables.
54756 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
54758 SAVE MOFSV,WIDWSV,WID2SV
54759 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
54761 C...Compressed code and sign; mass.
54768 C...Reset width information.
54773 C...Common electroweak and strong constants.
54776 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
54779 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
54781 RADC=1D0+AS/PARU(1)
54783 IF(KFLA.EQ.23) THEN
54785 XWC=1D0/(16D0*XW*XW1)
54786 FAC=(AEM*XWC/3D0)*SHR
54788 DO 130 I=1,MDCY(KC,3)
54790 IF(MDME(IDC,1).LT.0) GOTO 130
54791 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54792 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54793 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
54797 AF=SIGN(1D0,EF+0.1D0)
54800 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
54801 ELSEIF(I.LE.16) THEN
54802 C...Z0 -> l+ + l-, nu + nubar
54804 AF=SIGN(1D0,EF+0.1D0)
54808 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
54809 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
54811 WDTP(0)=WDTP(0)+WDTP(I)
54815 ELSEIF(KFLA.EQ.24) THEN
54817 FAC=(AEM/(24D0*XW))*SHR
54818 DO 140 I=1,MDCY(KC,3)
54820 IF(MDME(IDC,1).LT.0) GOTO 140
54821 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54822 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54823 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
54826 C...W+/- -> q + qbar'
54827 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
54828 ELSEIF(I.LE.20) THEN
54829 C...W+/- -> l+/- + nu
54832 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
54833 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
54834 WDTP(0)=WDTP(0)+WDTP(I)
54837 C.....V8 -> quark anti-quark
54838 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
54841 IF(ITCM(2).EQ.0) THEN
54843 ELSEIF(ITCM(2).EQ.1) THEN
54846 DO 150 I=1,MDCY(KC,3)
54848 IF(MDME(IDC,1).LT.0) GOTO 150
54849 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
54851 IF(RM1.GT.0.25D0) GOTO 150
54853 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
54858 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
54859 IF(I.EQ.6) WID2=WIDS(6,1)
54860 WDTP(0)=WDTP(0)+WDTP(I)
54867 C*********************************************************************
54870 C...Calculates R-violating decays of sfermions.
54873 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
54875 C...Double precision and integer declarations.
54876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54877 IMPLICIT INTEGER(I-N)
54878 C...Parameter statement to help give large particle numbers.
54879 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54880 &KEXCIT=4000000,KDIMEN=5000000)
54882 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54883 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54884 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54885 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54886 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54887 C...Local variables.
54888 DOUBLE PRECISION XLAM(0:400)
54889 INTEGER IDLAM(400,3), PYCOMP
54890 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
54892 C...IS R-VIOLATION ON ?
54893 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54894 C...Mass eigenstate counter
54895 ICNT=INT(KFIN/KSUSY1)
54896 C...SM KF code of SUSY particle
54897 KFSM=KFIN-ICNT*KSUSY1
54898 C...Squared Sparticle Mass
54899 SM=PMAS(PYCOMP(KFIN),1)**2
54900 C... Squared mass of top quark
54901 SMT=PMAS(PYCOMP(6),1)**2
54902 C...IS L-VIOLATION ON ?
54903 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
54904 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
54905 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
54911 C...~e,~mu,~tau -> nu_I + lepton-_J
54913 IDLAM(LKNT,1)= 12 +2*(I-1)
54914 IDLAM(LKNT,2)= 11 +2*(J-1)
54917 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54918 IF (IMSS(51).NE.0) XLAM(LKNT) =
54919 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54920 C...KINEMATICS CHECK
54921 IF (XLAM(LKNT).EQ.0D0) THEN
54927 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
54933 IDLAM(LKNT,1)=-12 -2*(I-1)
54934 IDLAM(LKNT,2)= 11 +2*(K-1)
54937 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54938 IF (IMSS(51).NE.0) XLAM(LKNT) =
54939 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54940 C...KINEMATICS CHECK
54941 IF (XLAM(LKNT).EQ.0D0) THEN
54947 C...~e,~mu,~tau -> u_Jbar + d_K
54952 IDLAM(LKNT,1)=-2 -2*(J-1)
54953 IDLAM(LKNT,2)= 1 +2*(K-1)
54956 IF (IMSS(52).NE.0) THEN
54957 C...Use massive top quark
54958 IF (IDLAM(LKNT,1).EQ.-6) THEN
54959 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
54962 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54963 C...If no top quark, all decay products massless
54965 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54967 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54969 C...KINEMATICS CHECK
54970 IF (XLAM(LKNT).EQ.0D0) THEN
54977 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
54978 C...No right-handed neutrinos
54980 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
54985 C...~nu_J -> lepton+_I + lepton-_K
54987 IDLAM(LKNT,1)=-11 -2*(I-1)
54988 IDLAM(LKNT,2)= 11 +2*(K-1)
54991 RM2=RVLAM(I,J,K)**2 * SM
54992 IF (IMSS(51).NE.0) XLAM(LKNT) =
54993 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54994 C...KINEMATICS CHECK
54995 IF (XLAM(LKNT).EQ.0D0) THEN
55001 C...~nu_I -> dbar_J + d_K
55006 IDLAM(LKNT,1)=-1 -2*(J-1)
55007 IDLAM(LKNT,2)= 1 +2*(K-1)
55010 RM2=3*RVLAMP(I,J,K)**2 * SM
55011 IF (IMSS(52).NE.0) XLAM(LKNT) =
55012 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55013 C...KINEMATICS CHECK
55014 IF (XLAM(LKNT).EQ.0D0) THEN
55021 C * SDOWN -> NU(BAR) + D and LEPTON- + U
55022 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55026 C...~d_J -> nu_Ibar + d_K
55028 IDLAM(LKNT,1)=-12 -2*(I-1)
55029 IDLAM(LKNT,2)= 1 +2*(K-1)
55032 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55033 IF (IMSS(52).NE.0) XLAM(LKNT) =
55034 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55035 C...KINEMATICS CHECK
55036 IF (XLAM(LKNT).EQ.0D0) THEN
55044 C...~d_K -> nu_I + d_J
55046 IDLAM(LKNT,1)= 12 +2*(I-1)
55047 IDLAM(LKNT,2)= 1 +2*(J-1)
55050 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55051 IF (IMSS(52).NE.0) XLAM(LKNT) =
55052 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55053 C...KINEMATICS CHECK
55054 IF (XLAM(LKNT).EQ.0D0) THEN
55057 C...~d_K -> lepton_I- + u_J
55059 IDLAM(LKNT,1)= 11 +2*(I-1)
55060 IDLAM(LKNT,2)= 2 +2*(J-1)
55063 IF (IMSS(52).NE.0) THEN
55064 C...Use massive top quark
55065 IF (IDLAM(LKNT,2).EQ.6) THEN
55066 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
55068 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
55069 C...If no top quark, all decay products massless
55071 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55073 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55075 C...KINEMATICS CHECK
55076 IF (XLAM(LKNT).EQ.0D0) THEN
55083 C * SUP -> LEPTON+ + D
55084 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55088 C...~u_J -> lepton_I+ + d_K
55090 IDLAM(LKNT,1)=-11 -2*(I-1)
55091 IDLAM(LKNT,2)= 1 +2*(K-1)
55094 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55095 IF (IMSS(52).NE.0) XLAM(LKNT) =
55096 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55097 C...KINEMATICS CHECK
55098 IF (XLAM(LKNT).EQ.0D0) THEN
55105 C...BARYON NUMBER VIOLATING DECAYS
55106 IF (IMSS(53).GE.1) THEN
55107 C * SUP -> DBAR + DBAR
55108 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55112 C...~u_I -> dbar_J + dbar_K
55114 C...(anti-) symmetry J <-> K.
55116 IDLAM(LKNT,1) = -1 -2*(J-1)
55117 IDLAM(LKNT,2) = -1 -2*(K-1)
55120 RM2 = 2.*(RVLAMB(I,J,K)**2)
55121 & * SFMIX(KFSM,2*ICNT)**2 * SM
55123 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55124 C...KINEMATICS CHECK
55125 IF (XLAM(LKNT).EQ.0D0) THEN
55132 C * SDOWN -> UBAR + DBAR
55133 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55137 C...LAMB coupling antisymmetric in J and K.
55139 C...~d_K -> ubar_I + dbar_K
55141 IDLAM(LKNT,1)= -2 -2*(I-1)
55142 IDLAM(LKNT,2)= -1 -2*(J-1)
55145 C...Use massive top quark
55146 IF (IDLAM(LKNT,1).EQ.-6) THEN
55147 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
55150 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
55151 C...If no top quark, all decay products massless
55153 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55155 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55157 C...KINEMATICS CHECK
55158 IF (XLAM(LKNT).EQ.0D0) THEN
55171 C*********************************************************************
55174 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
55177 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
55179 C...Double precision and integer declarations.
55180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55181 IMPLICIT INTEGER(I-N)
55182 C...Parameter statement to help give large particle numbers.
55183 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55184 &KEXCIT=4000000,KDIMEN=5000000)
55186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55187 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55188 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55189 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55190 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55191 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55192 C...Local variables.
55193 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55195 DOUBLE PRECISION XLAM(0:400)
55196 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
55197 INTEGER IDLAM(400,3), PYCOMP
55199 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
55201 C...R-VIOLATING DECAYS
55202 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55204 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
55205 C...WHICH NEUTRALINO ?
55207 IF (KFSM.EQ.23) NCHI=2
55208 IF (KFSM.EQ.25) NCHI=3
55209 IF (KFSM.EQ.35) NCHI=4
55210 C...SIGN OF MASS (Opposite convention as HERWIG)
55212 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
55214 C...Useful parameters for the calculation of the A and B constants.
55215 WMASS = PMAS(PYCOMP(24),1)
55216 ECHG = 2*SQRT(PARU(103)*PARU(1))
55217 COSB=1/(SQRT(1+RMSS(5)**2))
55218 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
55219 COSW=SQRT(1-PARU(102))
55220 SINW=SQRT(PARU(102))
55221 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
55222 C...Run quark masses to neutralino mass squared (for Higgs-type
55224 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
55226 RMQ(I)=PYMRUN(I,SQMCHI)
55228 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
55230 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
55231 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
55232 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
55233 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
55235 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
55236 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
55237 C2=ECHG*ZPMIX(NCHI,1)
55238 C3=GW*ZPMIX(NCHI,2)/COSW
55242 C x=1-2 : Select A or B constant (1:A ; 2:B)
55243 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55244 C 11-16:e,nu_e,mu,...)
55245 C z=1-2 : Mass eigenstate number
55246 C...CALCULATE COUPLINGS
55248 CMS=PMAS(PYCOMP(I),1)
55249 C...Intermediate sleptons
55250 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
55251 & *(C2-C3*SINW**2))
55252 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
55253 & *(C2-C3*SINW**2))
55254 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
55256 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
55258 C...Inermediate sneutrinos
55260 AB(2,I+1,1)=5D-1*C3
55263 C...Inermediate sdown
55266 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
55267 & *ED*(C2-C3*SINW**2))
55268 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
55269 & *ED*(C2-C3*SINW**2))
55270 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
55271 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55272 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
55273 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55274 C...Inermediate sup
55277 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
55278 & *EU*(C2-C3*SINW**2))
55279 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
55280 & *EU*(C2-C3*SINW**2))
55281 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
55282 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55283 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
55284 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55287 IF (IMSS(51).GE.1) THEN
55288 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
55289 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
55290 C...STEP IN I,J,K USING SINGLE COUNTER
55292 C...LAMBDA COUPLING ASYM IN I,J
55293 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55295 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55296 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55297 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55299 C...Set coupling, and decay product masses on/off
55300 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55301 & ,MOD(ISC,3)+1)**2
55303 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
55305 C...Resonance KF codes (1=I,2=J,3=K)
55306 KFR(1)=-IDLAM(LKNT,1)
55307 KFR(2)=-IDLAM(LKNT,2)
55308 KFR(3)=-IDLAM(LKNT,3)
55309 C...Calculate width.
55310 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55311 & IDLAM(LKNT,3),XLAM(LKNT))
55312 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55313 C...Charge conjugate mode.
55315 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55316 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55317 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55318 XLAM(LKNT)=XLAM(LKNT-1)
55319 C...KINEMATICS CHECK
55320 IF (XLAM(LKNT).EQ.0D0) THEN
55327 IF (IMSS(52).GE.1) THEN
55328 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
55329 C * CHI0 -> NUBAR_I + DBAR_J + D_K
55332 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55333 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55334 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55336 C...Set coupling, and decay product masses on/off
55337 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55338 & ,MOD(ISC,3)+1)**2
55340 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
55342 C...Resonance KF codes (1=I,2=J,3=K)
55343 KFR(1)=-IDLAM(LKNT,1)
55344 KFR(2)=-IDLAM(LKNT,2)
55345 KFR(3)=-IDLAM(LKNT,3)
55346 C...Calculate width.
55347 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55349 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55350 C...Charge conjugate mode.
55352 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55353 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55354 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55355 XLAM(LKNT)=XLAM(LKNT-1)
55356 C...KINEMATICS CHECK
55357 IF (XLAM(LKNT).EQ.0D0) THEN
55361 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
55363 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55364 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55365 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55367 C...Set coupling, and decay product masses on/off
55368 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55369 & ,MOD(ISC,3)+1)**2
55371 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
55372 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55373 C...Resonance KF codes (1=I,2=J,3=K)
55374 KFR(1)=-IDLAM(LKNT,1)
55375 KFR(2)=-IDLAM(LKNT,2)
55376 KFR(3)=-IDLAM(LKNT,3)
55377 C...Calculate width.
55378 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55380 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55381 C...Charge conjugate mode.
55383 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55384 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55385 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55386 XLAM(LKNT)=XLAM(LKNT-1)
55387 C...KINEMATICS CHECK
55388 IF (XLAM(LKNT).EQ.0D0) THEN
55394 IF (IMSS(53).GE.1) THEN
55395 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
55396 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
55398 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
55399 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
55401 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
55402 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55403 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55405 C...Set coupling, and decay product masses on/off
55406 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
55407 & +1,MOD(ISC,3)+1)**2
55409 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
55410 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
55411 C...Resonance KF codes (1=I,2=J,3=K)
55412 KFR(1) = IDLAM(LKNT,1)
55413 KFR(2) = IDLAM(LKNT,2)
55414 KFR(3) = IDLAM(LKNT,3)
55415 C...Calculate width.
55416 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55417 & IDLAM(LKNT,3),XLAM(LKNT))
55418 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55419 C...Charge conjugate mode.
55421 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55422 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55423 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55424 XLAM(LKNT)=XLAM(LKNT-1)
55425 C...KINEMATICS CHECK
55426 IF (XLAM(LKNT).EQ.0D0) THEN
55438 C*********************************************************************
55441 C...Calculates R-violating chargino decay widths.
55444 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
55446 C...Double precision and integer declarations.
55447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55448 IMPLICIT INTEGER(I-N)
55449 C...Parameter statement to help give large particle numbers.
55450 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55451 &KEXCIT=4000000,KDIMEN=5000000)
55453 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55454 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55455 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55456 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55457 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55458 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55459 C...Local variables.
55460 DOUBLE PRECISION XLAM(0:400)
55461 INTEGER IDLAM(400,3), PYCOMP
55462 C...Information from main routine to PYRVGW
55463 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55465 C...Auxiliary variables needed for BV (RV Gauge STOre)
55466 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55468 C...Running quark masses
55469 DOUBLE PRECISION RMQ(6)
55470 C...Decay product masses on/off
55472 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55476 C...IF R-VIOLATION ON.
55477 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55479 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
55480 C...WHICH CHARGINO ?
55482 IF (KFSM.EQ.37) NCHI = 2
55484 C...Useful parameters for calculating the A and B constants.
55485 C...SIGN OF MASS (Opposite convention as HERWIG)
55487 IF (SMW(NCHI).LT.0D0) ISM = -1
55488 WMASS = PMAS(PYCOMP(24),1)
55489 COSB = 1/(SQRT(1+RMSS(5)**2))
55490 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
55491 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
55492 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
55493 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
55496 C...Running masses at Q^2=MCHI^2.
55497 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
55499 RMQ(I)=PYMRUN(I,SQMCHI)
55502 C... AB(x,y,z) coefficients:
55503 C x=1-2 : A or B coefficient (1:A ; 2:B)
55504 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55505 C 11-16:e,nu_e,mu,...)
55506 C z=1-2 : Mass eigenstate number
55508 C...Intermediate sleptons
55511 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
55513 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
55515 C...Intermediate sneutrinos
55516 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
55518 AB(2,I+1,1) = ISM*C3
55520 C...Intermediate sdown
55522 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
55523 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
55524 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
55525 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
55526 C...Intermediate sup
55528 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
55529 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
55530 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
55531 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
55534 C...LLE TYPE R-VIOLATION
55535 IF (IMSS(51).GE.1) THEN
55536 C...LOOP OVER DECAY MODES
55539 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
55540 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55542 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
55543 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
55544 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
55546 C...Set coupling, and decay product masses on/off
55547 RVLAMC = GW2 * 5D-1 *
55548 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
55551 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
55552 C...Resonance KF codes (1=I,2=J,3=K).
55555 KFR(3) = -IDLAM(LKNT,3)+1
55556 C...Calculate width.
55557 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55558 & IDLAM(LKNT,3),XLAM(LKNT))
55559 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55560 C...KINEMATICS CHECK
55561 IF (XLAM(LKNT).EQ.0D0) THEN
55565 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
55566 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
55568 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55569 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
55570 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
55572 C...Set coupling, and decay product masses on/off
55573 RVLAMC = GW2 * 5D-1 *
55574 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55575 C...I,J SYMMETRY => FACTOR 2
55578 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
55579 C...Resonance KF codes (1=I,2=J,3=K)
55580 KFR(1)=IDLAM(LKNT,1)-1
55581 KFR(2)=IDLAM(LKNT,2)-1
55583 C...Calculate width.
55584 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55585 & IDLAM(LKNT,3),XLAM(LKNT))
55586 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55587 C...KINEMATICS CHECK
55588 IF (XLAM(LKNT).EQ.0D0) THEN
55593 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
55595 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55596 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55597 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55599 C...Set coupling, and decay product masses on/off
55600 RVLAMC = GW2 * 5D-1 *
55601 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55602 C...I,J SYMMETRY => FACTOR 2
55605 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
55606 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
55607 C...Resonance KF codes (1=I,2=J,3=K)
55608 KFR(1) =-IDLAM(LKNT,1)+1
55609 KFR(2) =-IDLAM(LKNT,2)+1
55611 C...Calculate width.
55612 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55613 & IDLAM(LKNT,3),XLAM(LKNT))
55614 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55615 C...KINEMATICS CHECK
55616 IF (XLAM(LKNT).EQ.0D0) THEN
55623 C...LQD TYPE R-VIOLATION
55624 IF (IMSS(52).GE.1) THEN
55625 C...LOOP OVER DECAY MODES
55628 C...CHI+ -> NUBAR_I + DBAR_J + U_K
55630 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55631 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55632 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55634 C...Set coupling, and decay product masses on/off
55635 RVLAMC = 3. * GW2 * 5D-1 *
55636 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55638 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
55640 C...Resonance KF codes (1=I,2=J,3=K)
55643 KFR(3)=-IDLAM(LKNT,3)+1
55644 C...Calculate width.
55645 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55647 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55648 C...KINEMATICS CHECK
55649 IF (XLAM(LKNT).EQ.0D0) THEN
55653 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
55655 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55656 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55657 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55659 C...Set coupling, and decay product masses on/off
55660 RVLAMC = 3. * GW2 * 5D-1 *
55661 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55663 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
55664 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
55665 C...Resonance KF codes (1=I,2=J,3=K)
55668 KFR(3)=-IDLAM(LKNT,3)+1
55669 C...Calculate width.
55670 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55672 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55673 C...KINEMATICS CHECK
55674 IF (XLAM(LKNT).EQ.0D0) THEN
55678 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
55680 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55681 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55682 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55684 C...Set coupling, and decay product masses on/off
55685 RVLAMC = 3. * GW2 * 5D-1 *
55686 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55688 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
55689 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
55690 C...Resonance KF codes (1=I,2=J,3=K)
55691 KFR(1)=-IDLAM(LKNT,1)+1
55692 KFR(2)=-IDLAM(LKNT,2)+1
55694 C...Calculate width.
55695 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55697 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55698 C...KINEMATICS CHECK
55699 IF (XLAM(LKNT).EQ.0D0) THEN
55703 C * CHI+ -> NU_I + U_J + DBAR_K.
55705 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55706 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55707 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55709 C...Set coupling, and decay product masses on/off
55711 RVLAMC = 3. * GW2 * 5D-1 *
55712 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55713 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
55715 C...Resonance KF codes (1=I,2=J,3=K)
55716 KFR(1)=IDLAM(LKNT,1)-1
55717 KFR(2)=IDLAM(LKNT,2)-1
55719 C...Calculate width.
55720 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55722 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55723 C...KINEMATICS CHECK
55724 IF (XLAM(LKNT).EQ.0D0) THEN
55731 C...UDD TYPE R-VIOLATION
55732 C...These decays need special treatment since more than one BV coupling
55733 C...contributes (with interference). Consider e.g. (symbolically)
55734 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
55735 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
55736 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
55737 C...The problem is that a single call to PYRVGW would evaluate all
55738 C...these terms and sum them, but without the different couplings. The
55739 C...way out is to call PYRVGW three times, once for the first line, once
55740 C...for the second line, and then once for all the lines (it is
55741 C...impossible to get just the last line out) without multiplying by
55742 C...couplings. The last line is then obtained as the result of the third
55743 C...call minus the results of the two first calls. Each term is then
55744 C...multiplied by its respective coupling before the whole thing is
55745 C...summed up in XLAM.
55746 C...Note that with three interfering resonances, this procedure becomes
55747 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
55749 IF (IMSS(53).GE.1) THEN
55750 C...LOOP OVER DECAY MODES
55753 C...CHI+ -> U_I + U_J + D_K
55754 C...Decay mode I<->J symmetric.
55755 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
55757 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
55758 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55759 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55761 C...Set coupling, and decay product masses on/off
55762 RVLAMC= 6. * GW2 * 5D-1
55763 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
55765 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55767 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
55770 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
55771 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
55772 C...Resonance KF codes (1=I,2=J,3=K)
55773 KFR(1) = -IDLAM(LKNT,1)+1
55776 C...Calculate width.
55777 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55778 & IDLAM(LKNT,3),XRESI)
55779 C...Resonance KF codes (1=I,2=J,3=K)
55781 KFR(2) = -IDLAM(LKNT,2)+1
55783 C...Calculate width.
55784 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55785 & IDLAM(LKNT,3),XRESJ)
55786 C...Resonance KF codes (1=I,2=J,3=K)
55787 KFR(1) = -IDLAM(LKNT,1)+1
55788 KFR(2) = -IDLAM(LKNT,2)+1
55790 C...Calculate width.
55791 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55792 & IDLAM(LKNT,3),XRESIJ)
55793 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
55794 XRESIJ = XRESIJ-XRESI-XRESJ
55798 C...CALCULATE TOTAL WIDTH
55799 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
55800 & + RVLJIK*RVLIJK * XRESIJ
55801 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55802 C...KINEMATICS CHECK
55803 IF (XLAM(LKNT).EQ.0D0) THEN
55807 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
55808 C...Symmetry I<->J<->K.
55809 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
55810 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
55812 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
55813 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55814 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55816 C...Set coupling, and decay product masses on/off
55817 RVLAMC = 6. * GW2 * 5D-1
55818 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55820 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
55822 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
55825 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
55826 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
55827 C...Collect symmetry factors
55828 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
55829 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
55830 & RVLAMC = 5D-1 * RVLAMC
55831 C...Resonance KF codes (1=I,2=J,3=K)
55832 KFR(1) = IDLAM(LKNT,1)-1
55835 C...Calculate width.
55836 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55837 & IDLAM(LKNT,3),XRESI)
55838 C...Resonance KF codes (1=I,2=J,3=K)
55840 KFR(2) = IDLAM(LKNT,2)-1
55842 C...Calculate width.
55843 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55844 & IDLAM(LKNT,3),XRESJ)
55845 C...Resonance KF codes (1=I,2=J,3=K)
55848 KFR(3) = IDLAM(LKNT,3)-1
55849 C...Calculate width.
55850 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55851 & IDLAM(LKNT,3),XRESK)
55852 C...Resonance KF codes (1=I,2=J,3=K)
55853 KFR(1) = IDLAM(LKNT,1)-1
55854 KFR(2) = IDLAM(LKNT,2)-1
55856 C...Calculate width.
55857 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55858 & IDLAM(LKNT,3),XRESIJ)
55859 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
55860 XRESIJ = XRESI+XRESJ-XRESIJ
55864 C...Resonance KF codes (1=I,2=J,3=K)
55866 KFR(2) = IDLAM(LKNT,2)-1
55867 KFR(3) = IDLAM(LKNT,3)-1
55868 C...Calculate width.
55869 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55870 & IDLAM(LKNT,3),XRESJK)
55871 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
55872 XRESJK = XRESJ+XRESK-XRESJK
55876 C...Resonance KF codes (1=I,2=J,3=K)
55877 KFR(1) = IDLAM(LKNT,1)-1
55879 KFR(3) = IDLAM(LKNT,3)-1
55880 C...Calculate width.
55881 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55882 & IDLAM(LKNT,3),XRESIK)
55883 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
55884 XRESIK = XRESI+XRESK-XRESIK
55888 C...CALCULATE TOTAL WIDTH
55890 & RVLIJK**2 * XRESI
55891 & + RVLJKI**2 * XRESJ
55892 & + RVLKIJ**2 * XRESK
55893 & + RVLIJK*RVLJKI * XRESIJ
55894 & + RVLIJK*RVLKIJ * XRESIK
55895 & + RVLJKI*RVLKIJ * XRESJK
55896 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
55897 C...KINEMATICS CHECK
55898 IF (XLAM(LKNT).EQ.0D0) THEN
55910 C*********************************************************************
55913 C...Calculates R-violating gluino decay widths.
55914 C...See BV part of PYRVCH for comments about the way the BV decay width
55915 C...is calculated. Same comments apply here.
55918 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
55920 C...Double precision and integer declarations.
55921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55922 IMPLICIT INTEGER(I-N)
55923 C...Parameter statement to help give large particle numbers.
55924 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55925 &KEXCIT=4000000,KDIMEN=5000000)
55927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55929 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55930 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55931 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55932 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55933 C...Local variables.
55934 DOUBLE PRECISION XLAM(0:400)
55935 INTEGER IDLAM(400,3), PYCOMP
55936 C...Information from main routine to PYRVGW
55937 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55939 C...Auxiliary variables needed for BV (RV Gauge STOre)
55940 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55942 C...Running quark masses
55943 DOUBLE PRECISION RMQ(6)
55944 C...Decay product masses on/off
55946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55949 C...IF LQD OR UDD TYPE R-VIOLATION ON.
55950 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
55954 C x=1-2 : Select A or B coupling (1:A ; 2:B)
55955 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55956 C 11-16:e,nu_e,mu,... not used here)
55957 C z=1-2 : Mass eigenstate number
55960 AB(1,I,1) = SFMIX(I,2)
55961 AB(1,I,2) = SFMIX(I,4)
55963 AB(2,I,1) = -SFMIX(I,1)
55964 AB(2,I,2) = -SFMIX(I,3)
55966 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
55968 IF (IMSS(52).GE.1) THEN
55969 C...STEP IN I,J,K USING SINGLE COUNTER
55971 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
55973 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55974 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55975 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55977 C...Set coupling, and decay product masses on/off
55978 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55981 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55982 C...Resonance KF codes (1=I,2=J,3=K)
55984 KFR(2) = -IDLAM(LKNT,2)
55985 KFR(3) = -IDLAM(LKNT,3)
55986 C...Calculate width.
55987 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55990 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55991 C...Charge conjugate mode.
55993 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
55994 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
55995 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
55996 XLAM(LKNT) = XLAM(LKNT-1)
55997 C...KINEMATICS CHECK
55998 IF (XLAM(LKNT).EQ.0D0) THEN
56002 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
56004 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
56005 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
56006 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
56008 C...Set coupling, and decay product masses on/off
56009 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56010 & **2* 5D-1 * GSTR2
56012 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
56013 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
56014 C...Resonance KF codes (1=I,2=J,3=K)
56016 KFR(2) = -IDLAM(LKNT,2)
56017 KFR(3) = -IDLAM(LKNT,3)
56018 C...Calculate width.
56019 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56021 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56022 C...Charge conjugate mode.
56024 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
56025 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
56026 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
56027 XLAM(LKNT) = XLAM(LKNT-1)
56028 C...KINEMATICS CHECK
56029 IF (XLAM(LKNT).EQ.0D0) THEN
56037 IF (IMSS(53).GE.1) THEN
56038 C...STEP IN I,J,K USING SINGLE COUNTER
56040 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
56041 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
56043 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
56044 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
56045 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
56047 C...Set coupling, and decay product masses on/off. A factor of 2 for
56048 C...(N_C-1) has been used to cancel a factor 0.5.
56049 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56052 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
56053 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
56054 C...Resonance KF codes (1=I,2=J,3=K)
56055 KFR(1) = IDLAM(LKNT,1)
56058 C...Calculate width.
56059 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56061 C...Resonance KF codes (1=I,2=J,3=K)
56063 KFR(2) = IDLAM(LKNT,2)
56065 C...Calculate width.
56066 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56068 C...Resonance KF codes (1=I,2=J,3=K)
56071 KFR(3) = IDLAM(LKNT,3)
56072 C...Calculate width.
56073 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56075 C...Resonance KF codes (1=I,2=J,3=K)
56076 KFR(1) = IDLAM(LKNT,1)
56077 KFR(2) = IDLAM(LKNT,2)
56079 C...Calculate width.
56080 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56082 C...Calculate interference function. (Factor -1/2 to make up for factor
56084 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
56085 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
56089 C...Resonance KF codes (1=I,2=J,3=K)
56091 KFR(2) = IDLAM(LKNT,2)
56092 KFR(3) = IDLAM(LKNT,3)
56093 C...Calculate width.
56094 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56096 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
56097 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
56101 C...Resonance KF codes (1=I,2=J,3=K)
56102 KFR(1) = IDLAM(LKNT,1)
56104 KFR(3) = IDLAM(LKNT,3)
56105 C...Calculate width.
56106 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56108 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
56109 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
56113 C...Calculate total width (factor 1/2 from 1/(N_C-1))
56114 XLAM(LKNT) = XRESI + XRESJ + XRESK
56115 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
56117 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56118 C...Charge conjugate mode.
56120 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56121 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56122 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56123 XLAM(LKNT) = XLAM(LKNT-1)
56124 C...KINEMATICS CHECK
56125 IF (XLAM(LKNT).EQ.0D0) THEN
56135 C*********************************************************************
56138 C...Auxiliary function to PYRVSF for calculating R-Violating
56139 C...sfermion widths. Though the decay products are most often treated
56140 C...as massless in the calculation, the kinematical boundary of phase
56141 C...space is tested using the true masses.
56142 C...MODE = 1: All decay products massive
56143 C...MODE = 2: Decay product 1 massless
56144 C...MODE = 3: Decay product 2 massless
56145 C...MODE = 4: All decay products massless
56147 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
56149 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56150 IMPLICIT INTEGER (I-N)
56151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56152 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56153 SAVE /PYDAT1/,/PYDAT2/
56154 DOUBLE PRECISION SM(3)
56155 INTEGER PYCOMP, KC(3)
56159 SM(1)=PMAS(KC(1),1)**2
56160 SM(2)=PMAS(KC(2),1)**2
56161 SM(3)=PMAS(KC(3),1)**2
56162 C...Kinematics check
56163 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
56167 C...CM momenta squared
56168 IF (MODE.EQ.1) THEN
56169 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
56170 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
56171 ELSE IF (MODE.EQ.2) THEN
56172 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
56173 ELSE IF (MODE.EQ.3) THEN
56174 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
56178 C...Calculate Width
56179 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
56183 C*********************************************************************
56186 C...Generalized Matrix Element for R-Violating 3-body widths.
56188 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
56190 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56191 IMPLICIT INTEGER (I-N)
56192 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56193 &KEXCIT=4000000,KDIMEN=5000000)
56194 PARAMETER (EPS=1D-4)
56195 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56196 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56198 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56199 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56200 DOUBLE PRECISION XLIM(3,3)
56201 INTEGER KC(0:3), PYCOMP
56202 LOGICAL DCMASS, DCHECK(6)
56203 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
56207 KC(0) = PYCOMP(KFIN)
56208 KC(1) = PYCOMP(ID1)
56209 KC(2) = PYCOMP(ID2)
56210 KC(3) = PYCOMP(ID3)
56211 RMS(0) = PMAS(KC(0),1)
56212 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
56213 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
56214 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
56215 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
56216 XLIM(1,1)=(RMS(1)+RMS(2))**2
56217 XLIM(1,2)=(RMS(0)-RMS(3))**2
56218 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
56219 XLIM(2,1)=(RMS(2)+RMS(3))**2
56220 XLIM(2,2)=(RMS(0)-RMS(1))**2
56221 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
56222 XLIM(3,1)=(RMS(1)+RMS(3))**2
56223 XLIM(3,2)=(RMS(0)-RMS(2))**2
56224 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
56225 C...Check Phase Space
56226 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
56230 C...INITIALIZE RESONANCE INFORMATION
56233 IRES = 2*(JRES-1)+IMASS
56235 DCHECK(IRES) =.FALSE.
56236 C...NO RIGHT-HANDED NEUTRINOS
56237 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
56238 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
56239 & .KFR(JRES).EQ.0) GOTO 100
56240 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
56241 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
56242 INTRES(IRES,1) = IABS(KFR(JRES))
56243 INTRES(IRES,2) = IMASS
56244 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
56245 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
56249 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
56251 C...RESONANCE CONTRIBUTIONS
56252 C...(Only sum contributions where the resonance is off shell).
56253 C...Store whether diagram on/off in DCHECK.
56254 C...LOOP OVER MASS STATES
56257 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56258 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
56259 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56260 DCHECK(IDR) =.TRUE.
56261 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
56265 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56266 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56267 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56268 DCHECK(IDR) =.TRUE.
56269 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
56273 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56274 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56275 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56276 DCHECK(IDR) =.TRUE.
56277 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
56280 C... L-R INTERFERENCES
56281 C... (Only add contributions where both contributing diagrams
56282 C... are non-resonant).
56284 IF (DCHECK(1).AND.DCHECK(2)) THEN
56285 C...Bug corrected 11/12 2001. Skands.
56286 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
56287 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
56288 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
56292 IF (DCHECK(3).AND.DCHECK(4)) THEN
56293 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
56294 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
56295 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
56299 IF (DCHECK(5).AND.DCHECK(6)) THEN
56300 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
56301 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
56302 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
56304 C... TRUE INTERFERENCES
56305 C... (Only add contributions where both contributing diagrams
56306 C... are non-resonant).
56308 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
56313 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56314 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
56315 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56316 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56321 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56322 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
56323 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56324 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56329 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56330 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
56331 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56332 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56340 C*********************************************************************
56343 C...Function to integrate resonance contributions
56345 FUNCTION PYRVI1(ID1,ID2,ID3)
56348 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
56349 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56350 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56351 LOGICAL MFLAG,DCMASS
56352 EXTERNAL PYRVG1,PYGAUS
56353 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56355 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56356 SAVE/PYRVNV/,/PYRVPM/
56357 C...Initialize mass and width information
56363 RESM(1)= RES(IDR,1)
56364 RESW(1)= RES(IDR,2)
56365 C...A->B and B->A for antisparticles
56366 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56367 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56368 C...Integration boundaries and mass flag
56369 LO = (RM(1)+RM(2))**2
56370 HI = (RM(0)-RM(3))**2
56372 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
56376 C*********************************************************************
56379 C...Function to integrate L-R interference contributions
56381 FUNCTION PYRVI2(ID1,ID2,ID3)
56384 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
56385 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56386 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56387 LOGICAL MFLAG,DCMASS
56388 EXTERNAL PYRVG2,PYGAUS
56389 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56391 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56392 SAVE/PYRVNV/,/PYRVPM/
56393 C...Initialize mass and width information
56399 RESM(1)= RES(IDR,1)
56400 RESW(1)= RES(IDR,2)
56401 RESM(2)= RES(IDR+1,1)
56402 RESW(2)= RES(IDR+1,2)
56403 C...A->B and B->A for antisparticles
56404 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56405 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56406 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56407 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56408 C...Boundaries and mass flag
56409 LO = (RM(1)+RM(2))**2
56410 HI = (RM(0)-RM(3))**2
56412 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
56416 C*********************************************************************
56419 C...Function to integrate true interference contributions
56421 FUNCTION PYRVI3(ID1,ID2,ID3)
56424 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
56425 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56426 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56427 LOGICAL MFLAG,DCMASS
56428 EXTERNAL PYRVG3,PYGAUS
56429 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56431 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56432 SAVE/PYRVNV/,/PYRVPM/
56433 C...Initialize mass and width information
56439 RESM(1)= RES(IDR,1)
56440 RESW(1)= RES(IDR,2)
56441 RESM(2)= RES(IDR2,1)
56442 RESW(2)= RES(IDR2,2)
56443 C...A -> B and B -> A for antisparticles
56444 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56445 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56446 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56447 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56448 C...Boundaries and mass flag
56449 LO = (RM(1)+RM(2))**2
56450 HI = (RM(0)-RM(3))**2
56452 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
56456 C*********************************************************************
56459 C...Integrand for resonance contributions
56464 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56465 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
56466 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
56469 RVR = PYRVR(X,RESM(1),RESW(1))
56470 C1 = 2D0*SQRT(MAX(0D0,X))
56471 IF (.NOT.MFLAG) THEN
56473 E3 = (RM(0)**2-X)/C1
56475 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
56477 E2 = (X-RM(1)**2+RM(2)**2)/C1
56478 E3 = (RM(0)**2-X-RM(3)**2)/C1
56479 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56480 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56481 DELTAY = 4D0*SR1*SR2
56482 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
56483 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
56484 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
56489 C*********************************************************************
56492 C...Integrand for L-R interference contributions
56497 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56498 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
56499 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
56502 C1 = 2D0*SQRT(MAX(0D0,X))
56503 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
56504 IF (.NOT.MFLAG) THEN
56506 E3 = (RM(0)**2-X)/C1
56508 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
56510 E2 = (X-RM(1)**2+RM(2)**2)/C1
56511 E3 = (RM(0)**2-X-RM(3)**2)/C1
56512 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56513 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56514 DELTAY = 4D0*SR1*SR2
56515 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
56516 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
56517 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
56522 C*********************************************************************
56525 C...Function to do Y integration over true interference contributions
56530 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56531 C...Second Dalitz variable for PYRVG4
56533 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
56534 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
56535 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
56537 EXTERNAL PYGAU2,PYRVG4
56538 SAVE/PYRVPM/,/PYG2DX/
56540 C1=2D0*SQRT(MAX(1D-9,X))
56542 IF (.NOT.MFLAG) THEN
56544 E3 = (RM(0)**2-X)/C1
56548 E2 = (X-RM(1)**2+RM(2)**2)/C1
56549 E3 = (RM(0)**2-X-RM(3)**2)/C1
56551 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56552 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56553 YMIN = SQ1-(SR1+SR2)**2
56554 YMAX = SQ1-(SR1-SR2)**2
56556 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
56560 C*********************************************************************
56563 C...Integrand for true intereference contributions
56568 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56570 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
56572 SAVE /PYRVPM/,/PYG2DX/
56574 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
56575 IF (.NOT.MFLAG) THEN
56576 PYRVG4 = RVS*B(1)*B(2)*X*Y
56578 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
56579 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
56580 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
56581 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
56586 C*********************************************************************
56589 C...Breit-Wigner for resonance contributions
56591 FUNCTION PYRVR(Mab2,RM,RW)
56594 DOUBLE PRECISION Mab2,RM,RW,PYRVR
56595 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
56599 C*********************************************************************
56602 C...Interference function
56604 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
56607 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
56608 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
56613 C*********************************************************************
56616 C...Stores one parton/particle in commonblock PYJETS.
56618 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
56620 C...Double precision and integer declarations.
56621 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56622 IMPLICIT INTEGER(I-N)
56623 INTEGER PYK,PYCHGE,PYCOMP
56625 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56626 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56627 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56628 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56630 C...Standard checks.
56632 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56633 IPA=MAX(1,IABS(IP))
56634 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
56635 &'(PY1ENT:) writing outside PYJETS memory')
56637 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
56639 C...Find mass. Reset K, P and V vectors.
56641 IF(MSTU(10).EQ.1) PM=P(IPA,5)
56642 IF(MSTU(10).GE.2) PM=PYMASS(KF)
56649 C...Store parton/particle in K and P vectors.
56651 IF(IP.LT.0) K(IPA,1)=2
56654 P(IPA,4)=MAX(PE,PM)
56655 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
56656 P(IPA,1)=PA*SIN(THE)*COS(PHI)
56657 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
56658 P(IPA,3)=PA*COS(THE)
56660 C...Set N. Optionally fragment/decay.
56662 IF(IP.EQ.0) CALL PYEXEC
56667 C*********************************************************************
56670 C...Stores two partons/particles in their CM frame,
56671 C...with the first along the +z axis.
56673 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
56675 C...Double precision and integer declarations.
56676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56677 IMPLICIT INTEGER(I-N)
56678 INTEGER PYK,PYCHGE,PYCOMP
56680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56683 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56685 C...Standard checks.
56687 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56688 IPA=MAX(1,IABS(IP))
56689 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
56690 &'(PY2ENT:) writing outside PYJETS memory')
56693 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
56694 &'(PY2ENT:) unknown flavour code')
56696 C...Find masses. Reset K, P and V vectors.
56698 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56699 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56701 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56702 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56711 C...Check flavours.
56712 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56713 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56714 IF(MSTU(19).EQ.1) THEN
56717 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
56718 & '(PY2ENT:) unphysical flavour combination')
56723 C...Store partons/particles in K vectors for normal case.
56726 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
56729 C...Store partons in K vectors for parton shower evolution.
56733 K(IPA,4)=MSTU(5)*(IPA+1)
56735 K(IPA+1,4)=MSTU(5)*IPA
56736 K(IPA+1,5)=K(IPA+1,4)
56739 C...Check kinematics and store partons/particles in P vectors.
56740 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
56741 &'(PY2ENT:) energy smaller than sum of masses')
56742 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
56745 P(IPA,4)=SQRT(PM1**2+PA**2)
56748 P(IPA+1,4)=SQRT(PM2**2+PA**2)
56751 C...Set N. Optionally fragment/decay.
56753 IF(IP.EQ.0) CALL PYEXEC
56758 C*********************************************************************
56761 C...Stores three partons or particles in their CM frame,
56762 C...with the first along the +z axis and the third in the (x,z)
56763 C...plane with x > 0.
56765 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
56767 C...Double precision and integer declarations.
56768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56769 IMPLICIT INTEGER(I-N)
56770 INTEGER PYK,PYCHGE,PYCOMP
56772 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56773 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56774 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56775 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56777 C...Standard checks.
56779 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56780 IPA=MAX(1,IABS(IP))
56781 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
56782 &'(PY3ENT:) writing outside PYJETS memory')
56786 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
56787 &'(PY3ENT:) unknown flavour code')
56789 C...Find masses. Reset K, P and V vectors.
56791 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56792 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56794 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56795 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56797 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56798 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56807 C...Check flavours.
56808 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56809 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56810 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56811 IF(MSTU(19).EQ.1) THEN
56813 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
56814 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
56815 & KQ1+KQ3.EQ.4)) THEN
56817 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
56823 C...Store partons/particles in K vectors for normal case.
56826 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
56828 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
56831 C...Store partons in K vectors for parton shower evolution.
56837 IF(KQ1.EQ.-1) KCS=5
56838 K(IPA,KCS)=MSTU(5)*(IPA+1)
56839 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
56840 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56841 K(IPA+1,9-KCS)=MSTU(5)*IPA
56842 K(IPA+2,KCS)=MSTU(5)*IPA
56843 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56846 C...Check kinematics.
56848 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
56849 &0.5D0*X3*PECM.LE.PM3) MKERR=1
56850 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
56851 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
56852 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
56853 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
56854 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
56855 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
56856 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
56857 IF(MKERR.NE.0) CALL PYERRM(13,
56858 &'(PY3ENT:) unphysical kinematical variable setup')
56860 C...Store partons/particles in P vectors.
56862 P(IPA,4)=SQRT(PA1**2+PM1**2)
56864 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
56865 P(IPA+2,3)=PA3*CTHE3
56866 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
56868 P(IPA+1,1)=-P(IPA+2,1)
56869 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
56870 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
56873 C...Set N. Optionally fragment/decay.
56875 IF(IP.EQ.0) CALL PYEXEC
56880 C*********************************************************************
56883 C...Stores four partons or particles in their CM frame, with
56884 C...the first along the +z axis, the last in the xz plane with x > 0
56885 C...and the second having y < 0 and y > 0 with equal probability.
56887 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
56889 C...Double precision and integer declarations.
56890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56891 IMPLICIT INTEGER(I-N)
56892 INTEGER PYK,PYCHGE,PYCOMP
56894 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56896 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56897 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56899 C...Standard checks.
56901 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56902 IPA=MAX(1,IABS(IP))
56903 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
56904 &'(PY4ENT:) writing outside PYJETS momory')
56909 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
56910 &'(PY4ENT:) unknown flavour code')
56912 C...Find masses. Reset K, P and V vectors.
56914 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56915 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56917 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56918 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56920 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56921 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56923 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
56924 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
56933 C...Check flavours.
56934 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56935 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56936 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56937 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
56938 IF(MSTU(19).EQ.1) THEN
56940 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
56941 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
56942 & KQ1+KQ4.EQ.4)) THEN
56943 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
56946 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
56953 C...Store partons/particles in K vectors for normal case.
56956 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
56958 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
56961 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
56964 C...Store partons for parton shower evolution from q-g-g-qbar or
56966 ELSEIF(KQ1+KQ2.NE.0) THEN
56972 IF(KQ1.EQ.-1) KCS=5
56973 K(IPA,KCS)=MSTU(5)*(IPA+1)
56974 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
56975 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56976 K(IPA+1,9-KCS)=MSTU(5)*IPA
56977 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
56978 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56979 K(IPA+3,KCS)=MSTU(5)*IPA
56980 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
56982 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
56988 K(IPA,4)=MSTU(5)*(IPA+1)
56990 K(IPA+1,4)=MSTU(5)*IPA
56991 K(IPA+1,5)=K(IPA+1,4)
56992 K(IPA+2,4)=MSTU(5)*(IPA+3)
56993 K(IPA+2,5)=K(IPA+2,4)
56994 K(IPA+3,4)=MSTU(5)*(IPA+2)
56995 K(IPA+3,5)=K(IPA+3,4)
56998 C...Check kinematics.
57000 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
57001 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
57003 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
57004 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
57005 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
57006 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
57007 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
57008 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
57009 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
57010 STHE4=SQRT(1D0-CTHE4**2)
57011 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
57012 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
57013 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
57014 STHE2=SQRT(1D0-CTHE2**2)
57015 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
57016 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
57017 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
57018 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
57019 IF(MKERR.EQ.1) CALL PYERRM(13,
57020 &'(PY4ENT:) unphysical kinematical variable setup')
57022 C...Store partons/particles in P vectors.
57024 P(IPA,4)=SQRT(PA1**2+PM1**2)
57026 P(IPA+3,1)=PA4*STHE4
57027 P(IPA+3,3)=PA4*CTHE4
57028 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
57030 P(IPA+1,1)=PA2*STHE2*CPHI2
57031 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
57032 P(IPA+1,3)=PA2*CTHE2
57033 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
57035 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
57036 P(IPA+2,2)=-P(IPA+1,2)
57037 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
57038 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
57041 C...Set N. Optionally fragment/decay.
57043 IF(IP.EQ.0) CALL PYEXEC
57048 C*********************************************************************
57051 C...An interface from a two-fermion generator to include
57052 C...parton showers and hadronization.
57054 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
57056 C...Double precision and integer declarations.
57057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57058 IMPLICIT INTEGER(I-N)
57059 INTEGER PYK,PYCHGE,PYCOMP
57061 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57063 SAVE /PYJETS/,/PYDAT1/
57065 DIMENSION IJOIN(2),INTAU(2)
57067 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57073 C...Loop through entries and pick up all final fermions/antifermions.
57077 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57079 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57080 IF(K(I,2).GT.0) THEN
57084 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
57090 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
57096 C...Check that event is arranged according to conventions.
57097 IF(I1.EQ.0.OR.I2.EQ.0) THEN
57098 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
57101 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
57104 C...Check whether fermion pair is quarks or leptons.
57105 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57107 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57110 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
57113 C...Decide whether to allow or not photon radiation in showers.
57115 IF(IRAD.EQ.0) MSTJ(41)=1
57117 C...Do colour joining and parton showers.
57120 IF(IQL12.EQ.1) THEN
57123 CALL PYJOIN(2,IJOIN)
57125 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57126 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57127 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57128 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57131 C...Do fragmentation and decays. Possibly except tau decay.
57135 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57149 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57157 C*********************************************************************
57160 C...An interface from a four-fermion generator to include
57161 C...parton showers and hadronization.
57163 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
57165 C...Double precision and integer declarations.
57166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57167 IMPLICIT INTEGER(I-N)
57168 INTEGER PYK,PYCHGE,PYCOMP
57170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57172 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57173 COMMON/PYINT1/MINT(400),VINT(400)
57174 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
57176 DIMENSION IJOIN(2),INTAU(4)
57178 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57184 C...Loop through entries and pick up all final fermions/antifermions.
57190 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57192 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57193 IF(K(I,2).GT.0) THEN
57196 ELSEIF(I3.EQ.0) THEN
57199 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
57204 ELSEIF(I4.EQ.0) THEN
57207 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
57213 C...Check that event is arranged according to conventions.
57214 IF(I3.EQ.0.OR.I4.EQ.0) THEN
57215 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
57217 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57218 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
57221 C...Check which fermion pairs are quarks and which leptons.
57222 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57224 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57227 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
57229 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57231 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57234 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
57237 C...Decide whether to allow or not photon radiation in showers.
57239 IF(IRAD.EQ.0) MSTJ(41)=1
57241 C...Decide on dipole pairing.
57246 IF(IQL12.EQ.IQL34) THEN
57249 DELTA=ATOTSQ-A1SQ-A2SQ
57250 IF(ISTRAT.EQ.1) THEN
57251 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
57252 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
57253 ELSEIF(ISTRAT.EQ.2) THEN
57254 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
57255 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
57257 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
57263 C...If colour reconnection then bookkeep W+W- or Z0Z0
57264 C...and copy q qbar q qbar consecutively.
57265 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57274 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
57278 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
57292 P(N+1,J)=P(IP1,J)+P(IP2,J)
57293 P(N+2,J)=P(IP3,J)+P(IP4,J)
57305 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57307 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57313 C...Remove original q qbar q qbar and update counters.
57314 K(IP1,1)=K(IP1,1)+10
57315 K(IP2,1)=K(IP2,1)+10
57316 K(IP3,1)=K(IP3,1)+10
57317 K(IP4,1)=K(IP4,1)+10
57328 C...Do colour joinings and parton showers.
57329 IF(IQL12.EQ.1) THEN
57332 CALL PYJOIN(2,IJOIN)
57334 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57335 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57336 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57337 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57340 IF(IQL34.EQ.1) THEN
57343 CALL PYJOIN(2,IJOIN)
57345 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57346 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57347 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57348 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57351 C...Optionally do colour reconnection.
57354 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57355 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
57359 C...Do fragmentation and decays. Possibly except tau decay.
57363 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57377 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57385 C*********************************************************************
57388 C...An interface from a six-fermion generator to include
57389 C...parton showers and hadronization.
57391 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
57393 C...Double precision and integer declarations.
57394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57395 IMPLICIT INTEGER(I-N)
57396 INTEGER PYK,PYCHGE,PYCOMP
57398 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57400 SAVE /PYJETS/,/PYDAT1/
57402 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
57404 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57410 C...Loop through entries and pick up all final fermions/antifermions.
57418 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57420 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57421 IF(K(I,2).GT.0) THEN
57424 ELSEIF(I3.EQ.0) THEN
57426 ELSEIF(I5.EQ.0) THEN
57429 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
57434 ELSEIF(I4.EQ.0) THEN
57436 ELSEIF(I6.EQ.0) THEN
57439 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
57445 C...Check that event is arranged according to conventions.
57446 IF(I5.EQ.0.OR.I6.EQ.0) THEN
57447 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
57449 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
57450 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
57453 C...Check which fermion pairs are quarks and which leptons.
57454 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57456 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57459 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
57461 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57463 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57466 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
57468 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
57470 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
57473 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
57476 C...Decide whether to allow or not photon radiation in showers.
57478 IF(IRAD.EQ.0) MSTJ(41)=1
57480 C...Allow dipole pairings only among leptons and quarks separately.
57483 IF(IQL34.EQ.IQL56) P13D=P13
57485 IF(IQL12.EQ.IQL34) P21D=P21
57487 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
57489 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
57491 IF(IQL12.EQ.IQL56) P32D=P32
57493 C...Decide whether t+tbar.
57495 IF(PYR(0).LT.PTOP) THEN
57498 C...If t+tbar: reconstruct t's.
57504 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
57505 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
57513 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
57515 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
57519 C...If t+tbar: colour join t's and let them shower.
57522 CALL PYJOIN(2,IJOIN)
57523 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
57524 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
57525 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57527 C...If t+tbar: pick up the t's after shower.
57531 IF(K(I,2).EQ.6) ITNEW=I
57532 IF(K(I,2).EQ.-6) ITBNEW=I
57535 C...If t+tbar: loop over two top systems.
57550 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
57551 & '(PY6FRM:) not b in t decay')
57553 C...If t+tbar: find boost from original to new top frame.
57555 BETAO(J)=P(ITO,J)/P(ITO,4)
57556 BETAN(J)=P(ITN,J)/P(ITN,4)
57559 C...If t+tbar: boost copy of b by t shower and connect it in colour.
57569 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57570 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57571 K(IB,4)=MSTU(5)*ITN
57572 K(IB,5)=MSTU(5)*ITN
57573 K(ITN,4)=K(ITN,4)+IB
57574 K(ITN,5)=K(ITN,5)+IB
57575 K(ITN,1)=K(ITN,1)+10
57576 K(IBO,1)=K(IBO,1)+10
57578 C...If t+tbar: construct W recoiling against b.
57586 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
57587 IF(IABS(KCHW).EQ.3) THEN
57588 K(IW,2)=ISIGN(24,KCHW)
57590 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
57594 C...If t+tbar: construct W momentum, including boost by t shower.
57596 P(IW,J)=P(IW1,J)+P(IW2,J)
57598 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
57600 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57601 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57603 C...If t+tbar: boost b and W to top rest frame.
57605 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
57607 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57608 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57610 C...If t+tbar: let b shower and pick up modified W.
57611 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
57612 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
57613 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
57615 IF(IABS(K(I,2)).EQ.24) IWM=I
57618 C...If t+tbar: take copy of W decay products.
57627 K(IW1,1)=K(IW1,1)+10
57628 K(IW2,1)=K(IW2,1)+10
57629 K(IWM,1)=K(IWM,1)+10
57643 C...If t+tbar: boost W decay products, first by effects of t shower,
57644 C...then by those of b shower. b and its shower simple boost back.
57645 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57646 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57647 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57648 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
57649 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
57650 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
57651 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
57652 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
57653 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
57657 C...Decide on dipole pairing.
57661 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
57662 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
57666 ELSEIF(PRN.LT.P12D+P13D) THEN
57670 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
57674 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
57678 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
57688 C...Do colour joinings and parton showers
57689 C...(except ones already made for t+tbar).
57691 IF(IQL12.EQ.1) THEN
57694 CALL PYJOIN(2,IJOIN)
57696 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57697 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57698 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57699 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57702 IF(IQL34.EQ.1) THEN
57705 CALL PYJOIN(2,IJOIN)
57707 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57708 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57709 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57710 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57712 IF(IQL56.EQ.1) THEN
57715 CALL PYJOIN(2,IJOIN)
57717 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
57718 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
57719 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
57720 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57723 C...Do fragmentation and decays. Possibly except tau decay.
57727 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57741 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57749 C*********************************************************************
57752 C...An interface from a four-parton generator to include
57753 C...parton showers and hadronization.
57755 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
57757 C...Double precision and integer declarations.
57758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57759 IMPLICIT INTEGER(I-N)
57760 INTEGER PYK,PYCHGE,PYCOMP
57762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57764 SAVE /PYJETS/,/PYDAT1/
57766 DIMENSION IJOIN(2),PTOT(4),BETA(3)
57768 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57774 C...Loop through entries and pick up all final partons.
57780 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57782 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
57783 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
57786 ELSEIF(I3.EQ.0) THEN
57789 CALL PYERRM(16,'(PY4JET:) more than two quarks')
57791 ELSEIF(K(I,2).LT.0) THEN
57794 ELSEIF(I4.EQ.0) THEN
57797 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
57802 ELSEIF(I4.EQ.0) THEN
57805 CALL PYERRM(16,'(PY4JET:) more than two gluons')
57811 C...Check that event is arranged according to conventions.
57812 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
57813 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
57815 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57816 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
57819 C...Check whether second pair are quarks or gluons.
57820 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57822 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
57825 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
57828 C...Boost partons to their cm frame.
57830 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
57832 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
57834 BETA(J)=PTOT(J)/PTOT(4)
57836 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57837 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57838 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57839 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57842 C...Decide and set up shower history for q qbar q' qbar' events.
57843 IF(IQG34.EQ.1) THEN
57844 W1=PY4JTW(0,I1,I3,I4)
57845 W2=PY4JTW(0,I2,I3,I4)
57846 IF(W1.GT.PYR(0)*(W1+W2)) THEN
57847 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57849 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57852 C...Decide and set up shower history for q qbar g g events.
57854 W1=PY4JTW(I1,I3,I2,I4)
57855 W2=PY4JTW(I1,I4,I2,I3)
57856 W3=PY4JTW(0,I3,I1,I4)
57857 W4=PY4JTW(0,I4,I1,I3)
57858 W5=PY4JTW(0,I3,I2,I4)
57859 W6=PY4JTW(0,I4,I2,I3)
57860 W7=PY4JTW(0,I1,I3,I4)
57861 W8=PY4JTW(0,I2,I3,I4)
57862 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
57864 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
57865 ELSEIF(W1+W2.GT.WR) THEN
57866 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
57867 ELSEIF(W1+W2+W3.GT.WR) THEN
57868 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
57869 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
57870 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
57871 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
57872 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
57873 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
57874 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
57875 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
57876 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57878 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57882 C...Boost back original partons and mark them as deleted.
57883 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
57884 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
57885 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
57886 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
57892 C...Rotate shower initiating partons to be along z axis.
57893 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
57894 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
57895 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
57896 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
57898 C...Set up copy of shower initiating partons as on mass shell.
57908 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
57919 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
57920 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
57922 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
57924 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
57927 C...Decide whether to allow or not photon radiation in showers.
57928 C...Connect up colours.
57930 IF(IRAD.EQ.0) MSTJ(41)=1
57933 CALL PYJOIN(2,IJOIN)
57935 C...Decide on maximum virtuality and do parton shower.
57936 IF(PMAX.LT.PARJ(82)) THEN
57941 CALL PYSHOW(NSAV+1,-100,PQMAX)
57943 C...Rotate and boost back system.
57944 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
57946 C...Do fragmentation and decays.
57949 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57958 C*********************************************************************
57961 C...Auxiliary to PY4JET, to evaluate weight of configuration.
57963 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
57965 C...Double precision and integer declarations.
57966 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57967 IMPLICIT INTEGER(I-N)
57968 INTEGER PYK,PYCHGE,PYCOMP
57970 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57973 C...First case: when both original partons radiate.
57974 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
57977 P(N+1,J)=P(IA1,J)+P(IA2,J)
57978 P(N+2,J)=P(IA3,J)+P(IA4,J)
57980 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57982 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57984 Z1=P(IA1,4)/P(N+1,4)
57985 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
57986 Z2=P(IA3,4)/P(N+2,4)
57987 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
57989 C...Second case: when one original parton radiates to three.
57990 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
57993 P(N+2,J)=P(IA3,J)+P(IA4,J)
57994 P(N+1,J)=P(N+2,J)+P(IA2,J)
57996 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57998 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58000 IF(K(IA2,2).EQ.21) THEN
58001 Z1=P(N+2,4)/P(N+1,4)
58002 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58005 Z1=P(IA2,4)/P(N+1,4)
58006 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58009 Z2=P(IA3,4)/P(N+2,4)
58010 IF(K(IA2,2).EQ.21) THEN
58011 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
58013 ELSEIF(K(IA3,2).EQ.21) THEN
58014 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
58016 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
58026 C*********************************************************************
58029 C...Auxiliary to PY4JET, to set up chosen configuration.
58031 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
58033 C...Double precision and integer declarations.
58034 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58035 IMPLICIT INTEGER(I-N)
58036 INTEGER PYK,PYCHGE,PYCOMP
58038 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58050 C...First case: when both original partons radiate.
58051 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
58054 C...Set up flavour and history pointers for new partons.
58072 C...Set up momenta for new partons.
58074 P(N+1,J)=P(IA1,J)+P(IA2,J)
58075 P(N+2,J)=P(IA3,J)+P(IA4,J)
58081 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58083 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58085 QMAX=MIN(P(N+1,5),P(N+2,5))
58087 C...Second case: q radiates twice.
58088 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
58089 C...IA5=N+2 does not radiate.
58090 ELSEIF(K(IA2,2).EQ.21) THEN
58092 C...Set up flavour and history pointers for new partons.
58110 C...Set up momenta for new partons.
58112 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58114 P(N+3,J)=P(IA3,J)+P(IA4,J)
58119 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58121 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
58125 C...Third case: q radiates g, g branches.
58126 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
58127 C...IA5=N+2 does not radiate.
58130 C...Set up flavour and history pointers for new partons.
58148 C...Set up momenta for new partons.
58150 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58153 P(N+4,J)=P(IA3,J)+P(IA4,J)
58157 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58159 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
58169 C*********************************************************************
58172 C...Connects a sequence of partons with colour flow indices,
58173 C...as required for subsequent shower evolution (or other operations).
58175 SUBROUTINE PYJOIN(NJOIN,IJOIN)
58177 C...Double precision and integer declarations.
58178 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58179 IMPLICIT INTEGER(I-N)
58180 INTEGER PYK,PYCHGE,PYCOMP
58182 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58184 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58185 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58189 C...Check that partons are of right types to be connected.
58190 IF(NJOIN.LT.2) GOTO 120
58194 IF(I.LE.0.OR.I.GT.N) GOTO 120
58195 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
58197 IF(KC.EQ.0) GOTO 120
58198 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
58199 IF(KQ.EQ.0) GOTO 120
58200 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
58201 IF(KQ.NE.2) KQSUM=KQSUM+KQ
58202 IF(IJN.EQ.1) KQS=KQ
58204 IF(KQSUM.NE.0) GOTO 120
58206 C...Connect the partons sequentially (closing for gluon loop).
58208 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
58212 IF(IJN.NE.1) IP=IJOIN(IJN-1)
58213 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
58214 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
58215 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
58216 K(I,KCS)=MSTU(5)*IN
58217 K(I,9-KCS)=MSTU(5)*IP
58218 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
58219 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
58222 C...Error exit: no action taken.
58224 120 CALL PYERRM(12,
58225 &'(PYJOIN:) given entries can not be joined by one string')
58230 C*********************************************************************
58233 C...Sets values of commonblock variables.
58235 SUBROUTINE PYGIVE(CHIN)
58237 C...Double precision and integer declarations.
58238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58239 IMPLICIT INTEGER(I-N)
58240 INTEGER PYK,PYCHGE,PYCOMP
58242 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58244 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58245 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58246 COMMON/PYDAT4/CHAF(500,2)
58248 COMMON/PYDATR/MRPY(6),RRPY(100)
58249 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
58250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58251 COMMON/PYINT1/MINT(400),VINT(400)
58252 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
58253 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
58254 COMMON/PYINT4/MWID(500),WIDS(500,5)
58255 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
58256 COMMON/PYINT6/PROC(0:500)
58258 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
58259 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
58261 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58262 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58263 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
58264 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
58265 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
58266 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
58267 C...Local arrays and character variables.
58268 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
58269 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
58271 DIMENSION MSVAR(54,8)
58273 C...For each variable to be translated give: name,
58274 C...integer/real/character, no. of indices, lower&upper index bounds.
58275 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
58276 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
58277 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
58278 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
58279 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
58280 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
58282 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
58283 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
58284 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58285 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
58286 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
58287 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
58288 &1,1,1,6,4*0, 2,1,1,100,4*0,
58289 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
58290 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58291 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
58292 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
58293 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
58294 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
58295 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
58296 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
58297 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
58298 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
58299 &1,1,0,99,4*0, 2,1,0,99,4*0/
58300 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58301 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
58303 C...Length of character variable. Subdivide it into instructions.
58304 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
58305 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
58309 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
58312 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
58314 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
58319 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
58321 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
58323 C...Send off decay-mode on/off commands to PYONOF.
58326 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
58328 IF(IONOF.EQ.1) THEN
58333 C...Peel off any text following exclamation mark.
58335 DO 140 LLOW2=LHIG2,1,-1
58336 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
58338 IF(LBIT.EQ.0) RETURN
58340 C...Identify commonblock variable.
58343 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
58344 &LNAM.LE.6) GOTO 150
58345 CHNAM=CHBIT(1:LNAM-1)//' '
58346 DO 170 LCOM=1,LNAM-1
58348 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
58349 & CHALP(2)(LALP:LALP)
58354 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
58357 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
58359 IF(LLOW.LT.LTOT) GOTO 120
58363 C...Identify any indices.
58368 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
58371 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
58373 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
58374 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
58375 & IVAR.EQ.37)) THEN
58376 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
58377 READ(CHIND,'(I8)') KF
58379 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
58381 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
58384 IF(LLOW.LT.LTOT) GOTO 120
58387 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58388 READ(CHIND,'(I8)') I1
58391 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58394 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58397 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
58399 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58400 READ(CHIND,'(I8)') I2
58402 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58405 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58408 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
58410 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58411 READ(CHIND,'(I8)') I3
58416 C...Check that indices allowed.
58418 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
58419 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
58421 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
58423 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
58425 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
58427 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
58430 IF(LLOW.LT.LTOT) GOTO 120
58434 C...Save old value of variable.
58437 ELSEIF(IVAR.EQ.2) THEN
58439 ELSEIF(IVAR.EQ.3) THEN
58441 ELSEIF(IVAR.EQ.4) THEN
58443 ELSEIF(IVAR.EQ.5) THEN
58445 ELSEIF(IVAR.EQ.6) THEN
58447 ELSEIF(IVAR.EQ.7) THEN
58449 ELSEIF(IVAR.EQ.8) THEN
58451 ELSEIF(IVAR.EQ.9) THEN
58453 ELSEIF(IVAR.EQ.10) THEN
58455 ELSEIF(IVAR.EQ.11) THEN
58457 ELSEIF(IVAR.EQ.12) THEN
58459 ELSEIF(IVAR.EQ.13) THEN
58461 ELSEIF(IVAR.EQ.14) THEN
58463 ELSEIF(IVAR.EQ.15) THEN
58465 ELSEIF(IVAR.EQ.16) THEN
58467 ELSEIF(IVAR.EQ.17) THEN
58468 CHOLD=CHAF(I1,I2)(1:8)
58469 ELSEIF(IVAR.EQ.18) THEN
58471 ELSEIF(IVAR.EQ.19) THEN
58473 ELSEIF(IVAR.EQ.20) THEN
58475 ELSEIF(IVAR.EQ.21) THEN
58477 ELSEIF(IVAR.EQ.22) THEN
58479 ELSEIF(IVAR.EQ.23) THEN
58481 ELSEIF(IVAR.EQ.24) THEN
58483 ELSEIF(IVAR.EQ.25) THEN
58485 ELSEIF(IVAR.EQ.26) THEN
58487 ELSEIF(IVAR.EQ.27) THEN
58489 ELSEIF(IVAR.EQ.28) THEN
58491 ELSEIF(IVAR.EQ.29) THEN
58493 ELSEIF(IVAR.EQ.30) THEN
58495 ELSEIF(IVAR.EQ.31) THEN
58497 ELSEIF(IVAR.EQ.32) THEN
58499 ELSEIF(IVAR.EQ.33) THEN
58500 IOLD=ICOL(I1,I2,I3)
58501 ELSEIF(IVAR.EQ.34) THEN
58503 ELSEIF(IVAR.EQ.35) THEN
58505 ELSEIF(IVAR.EQ.36) THEN
58507 ELSEIF(IVAR.EQ.37) THEN
58509 ELSEIF(IVAR.EQ.38) THEN
58511 ELSEIF(IVAR.EQ.39) THEN
58513 ELSEIF(IVAR.EQ.40) THEN
58515 ELSEIF(IVAR.EQ.41) THEN
58517 ELSEIF(IVAR.EQ.42) THEN
58518 ROLD=SIGT(I1,I2,I3)
58519 ELSEIF(IVAR.EQ.43) THEN
58521 ELSEIF(IVAR.EQ.44) THEN
58523 ELSEIF(IVAR.EQ.45) THEN
58525 ELSEIF(IVAR.EQ.46) THEN
58527 ELSEIF(IVAR.EQ.47) THEN
58529 ELSEIF(IVAR.EQ.48) THEN
58531 ELSEIF(IVAR.EQ.49) THEN
58533 ELSEIF(IVAR.EQ.50) THEN
58534 ROLD=RVLAM(I1,I2,I3)
58535 ELSEIF(IVAR.EQ.51) THEN
58536 ROLD=RVLAMP(I1,I2,I3)
58537 ELSEIF(IVAR.EQ.52) THEN
58538 ROLD=RVLAMB(I1,I2,I3)
58539 ELSEIF(IVAR.EQ.53) THEN
58541 ELSEIF(IVAR.EQ.54) THEN
58545 C...Print current value of variable. Loop back.
58546 IF(LNAM.GE.LBIT) THEN
58548 CHBIT(15:60)=' has the value '
58549 IF(MSVAR(IVAR,1).EQ.1) THEN
58550 WRITE(CHBIT(51:60),'(I10)') IOLD
58551 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58552 WRITE(CHBIT(47:60),'(F14.5)') ROLD
58553 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58558 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58560 IF(LLOW.LT.LTOT) GOTO 120
58564 C...Read in new variable value.
58565 IF(MSVAR(IVAR,1).EQ.1) THEN
58567 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
58568 READ(CHINI,'(I10)') INEW
58569 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58571 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
58573 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58574 CHNEW=CHBIT(LNAM+1:LBIT)//' '
58576 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
58579 C...Store new variable value.
58582 ELSEIF(IVAR.EQ.2) THEN
58584 ELSEIF(IVAR.EQ.3) THEN
58586 ELSEIF(IVAR.EQ.4) THEN
58588 ELSEIF(IVAR.EQ.5) THEN
58590 ELSEIF(IVAR.EQ.6) THEN
58592 ELSEIF(IVAR.EQ.7) THEN
58594 ELSEIF(IVAR.EQ.8) THEN
58596 ELSEIF(IVAR.EQ.9) THEN
58598 ELSEIF(IVAR.EQ.10) THEN
58600 ELSEIF(IVAR.EQ.11) THEN
58602 ELSEIF(IVAR.EQ.12) THEN
58604 ELSEIF(IVAR.EQ.13) THEN
58606 ELSEIF(IVAR.EQ.14) THEN
58608 ELSEIF(IVAR.EQ.15) THEN
58610 ELSEIF(IVAR.EQ.16) THEN
58612 ELSEIF(IVAR.EQ.17) THEN
58614 ELSEIF(IVAR.EQ.18) THEN
58616 ELSEIF(IVAR.EQ.19) THEN
58618 ELSEIF(IVAR.EQ.20) THEN
58620 ELSEIF(IVAR.EQ.21) THEN
58622 ELSEIF(IVAR.EQ.22) THEN
58624 ELSEIF(IVAR.EQ.23) THEN
58626 ELSEIF(IVAR.EQ.24) THEN
58628 ELSEIF(IVAR.EQ.25) THEN
58630 ELSEIF(IVAR.EQ.26) THEN
58632 ELSEIF(IVAR.EQ.27) THEN
58634 ELSEIF(IVAR.EQ.28) THEN
58636 ELSEIF(IVAR.EQ.29) THEN
58638 ELSEIF(IVAR.EQ.30) THEN
58640 ELSEIF(IVAR.EQ.31) THEN
58642 ELSEIF(IVAR.EQ.32) THEN
58644 ELSEIF(IVAR.EQ.33) THEN
58645 ICOL(I1,I2,I3)=INEW
58646 ELSEIF(IVAR.EQ.34) THEN
58648 ELSEIF(IVAR.EQ.35) THEN
58650 ELSEIF(IVAR.EQ.36) THEN
58652 ELSEIF(IVAR.EQ.37) THEN
58654 ELSEIF(IVAR.EQ.38) THEN
58656 ELSEIF(IVAR.EQ.39) THEN
58658 ELSEIF(IVAR.EQ.40) THEN
58660 ELSEIF(IVAR.EQ.41) THEN
58662 ELSEIF(IVAR.EQ.42) THEN
58663 SIGT(I1,I2,I3)=RNEW
58664 ELSEIF(IVAR.EQ.43) THEN
58666 ELSEIF(IVAR.EQ.44) THEN
58668 ELSEIF(IVAR.EQ.45) THEN
58670 ELSEIF(IVAR.EQ.46) THEN
58672 ELSEIF(IVAR.EQ.47) THEN
58674 ELSEIF(IVAR.EQ.48) THEN
58676 ELSEIF(IVAR.EQ.49) THEN
58678 ELSEIF(IVAR.EQ.50) THEN
58679 RVLAM(I1,I2,I3)=RNEW
58680 ELSEIF(IVAR.EQ.51) THEN
58681 RVLAMP(I1,I2,I3)=RNEW
58682 ELSEIF(IVAR.EQ.52) THEN
58683 RVLAMB(I1,I2,I3)=RNEW
58684 ELSEIF(IVAR.EQ.53) THEN
58686 ELSEIF(IVAR.EQ.54) THEN
58690 C...Write old and new value. Loop back.
58692 CHBIT(15:60)=' changed from to '
58693 IF(MSVAR(IVAR,1).EQ.1) THEN
58694 WRITE(CHBIT(33:42),'(I10)') IOLD
58695 WRITE(CHBIT(51:60),'(I10)') INEW
58696 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58697 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58698 WRITE(CHBIT(29:42),'(F14.5)') ROLD
58699 WRITE(CHBIT(47:60),'(F14.5)') RNEW
58700 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58701 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58704 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58706 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
58707 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
58710 IF(LLOW.LT.LTOT) GOTO 120
58712 C...Format statement for output on unit MSTU(11) (by default 6).
58713 5000 FORMAT(5X,A60)
58714 5100 FORMAT(5X,A88)
58719 C*********************************************************************
58722 C...Switches on and off decay channel by search for match.
58724 SUBROUTINE PYONOF(CHIN)
58726 C...Double precision and integer declarations.
58727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58728 IMPLICIT INTEGER(I-N)
58729 INTEGER PYK,PYCHGE,PYCOMP
58731 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58732 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58733 SAVE /PYDAT1/,/PYDAT3/
58734 C...Local arrays and character variables.
58735 INTEGER KFCMP(10),KFTMP(10)
58736 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
58738 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58739 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
58741 C...Determine length of character variable.
58745 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
58748 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
58750 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
58752 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
58754 C...Find colon separator and particle code.
58756 120 LCOLON=LCOLON+1
58757 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
58759 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
58760 READ(CHCODE,'(I8)',ERR=300) KF
58763 C...Done if unknown code or no decay channels.
58765 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
58770 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
58771 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
58775 C...Find command name up to blank or equal sign.
58778 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
58779 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
58781 LMODE=LSEP-LCOLON-1
58782 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
58784 C...Convert to uppercase.
58785 DO 150 LCOM=1,LMODE
58787 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
58788 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
58792 C...Identify command. Failed if not identified.
58794 IF(CHMODE.EQ.'ALLOFF') MODE=1
58795 IF(CHMODE.EQ.'ALLON') MODE=2
58796 IF(CHMODE.EQ.'OFFIFANY') MODE=3
58797 IF(CHMODE.EQ.'ONIFANY') MODE=4
58798 IF(CHMODE.EQ.'OFFIFALL') MODE=5
58799 IF(CHMODE.EQ.'ONIFALL') MODE=6
58800 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
58801 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
58803 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
58807 C...Simple cases when all on or all off.
58808 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
58809 WRITE(MSTU(11),1000) KF,CHMODE
58810 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
58811 IF(MDME(IDC,1).LT.0) GOTO 160
58817 C...Identify matching list.
58821 IF(LBEG.GT.LEN) GOTO 190
58822 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
58823 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
58826 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
58827 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
58828 IF(LEND.LT.LEN) LEND=LEND-1
58830 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
58831 READ(CHCODE,'(I8)',ERR=300) KFREAD
58833 KFCMP(NCMP)=IABS(KFREAD)
58835 IF(NCMP.LT.10) GOTO 170
58837 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
58839 C...Only one matching required.
58840 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
58841 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
58842 IF(MDME(IDC,1).LT.0) GOTO 220
58844 KFNOW=IABS(KFDP(IDC,IKF))
58845 IF(KFNOW.EQ.0) GOTO 210
58847 IF(KFCMP(ICMP).EQ.KFNOW) THEN
58857 C...Multiple matchings required.
58858 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
58859 IF(MDME(IDC,1).LT.0) GOTO 260
58862 KFTMP(ITMP)=KFCMP(ITMP)
58866 KFNOW=IABS(KFDP(IDC,IKF))
58867 IF(KFNOW.EQ.0) GOTO 250
58870 IF(KFTMP(ITMP).EQ.KFNOW) THEN
58871 KFTMP(ITMP)=KFTMP(NTMP)
58877 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
58878 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
58879 & MDME(IDC,1)=MODE-7
58883 C...Error exit for impossible read of particle code.
58884 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
58887 C...Formats for output.
58888 1000 FORMAT(' Decays for',I8,' set ',A10)
58889 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
58893 C*********************************************************************
58896 C...Presets for a few specific underlying-event and min-bias tunes
58897 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
58898 C...others require particular versions of pythia (e.g. the SCI and GAL
58899 C...models). See below for details.
58900 SUBROUTINE PYTUNE(ITUNE)
58902 C ITUNE NAME (detailed descriptions below)
58903 C 0 Default : No settings changed => linked Pythia version's defaults.
58904 C ====== Old UE, Q2-ordered showers ==========================================
58905 C 100 A : Rick Field's CDF Tune A
58906 C 101 AW : Rick Field's CDF Tune AW
58907 C 102 BW : Rick Field's CDF Tune BW
58908 C 103 DW : Rick Field's CDF Tune DW
58909 C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
58910 C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
58911 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
58912 C 107 ACR : Tune A modified with annealing CR
58913 C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
58914 C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
58915 C ====== Intermediate Models =================================================
58916 C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
58917 C 201 APT : Tune A modified to use pT-ordered final-state showers
58918 C ====== New UE, interleaved pT-ordered showers, annealing CR ================
58919 C 300 S0 : Sandhoff-Skands Tune 0
58920 C 301 S1 : Sandhoff-Skands Tune 1
58921 C 302 S2 : Sandhoff-Skands Tune 2
58922 C 303 S0A : S0 with "Tune A" UE energy scaling
58923 C 304 NOCR : New UE "best try" without colour reconnections
58924 C 305 Old : New UE, original (primitive) colour reconnections
58925 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
58926 C ======= The Uppsala models =================================================
58927 C ( NB! must be run with special modified Pythia 6.215 version )
58928 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
58929 C 400 GAL 0 : Generalized area-law model. Old parameters
58930 C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
58931 C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
58932 C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
58936 C Quick Dictionary:
58937 C BE : Bose-Einstein
58938 C BR : Beam Remnants
58939 C CR : Colour Reconnections
58940 C HAD: Hadronization
58941 C ISR/FSR: Initial-State Radiation / Final-State Radiation
58942 C FSI: Final-State Interactions (=CR+BE)
58943 C MB : Minimum-bias
58944 C MI : Multiple Interactions
58945 C UE : Underlying Event
58947 C A (100) and AW (101). Old UE model, Q2-ordered showers.
58948 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58949 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58950 C...Key feature: extensively compared to CDF data (R.D. Field).
58951 C...* Large starting scale for ISR (PARP(67)=4)
58952 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
58953 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58955 C BW (102). Old UE model, Q2-ordered showers.
58956 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58957 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58958 C...Key feature: extensively compared to CDF data (R.D. Field).
58959 C...NB: Can also be run with Pythia 6.2 or 6.312+
58960 C...* Small starting scale for ISR (PARP(67)=1)
58961 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
58962 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58964 C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
58965 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58966 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58967 C...Key feature: extensively compared to CDF data (R.D. Field).
58968 C...NB: Can also be run with Pythia 6.2 or 6.312+
58969 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
58970 C...* DWT has a different reference energy, the same as the "S" models
58971 C... below, leading to more UE activity at the LHC, but less at RHIC.
58972 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58974 C QW (105). Old UE model, Q2-ordered showers.
58975 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58976 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58977 C...Key feature: uses CTEQ61 (external pdf library must be linked)
58979 C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
58980 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58981 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58982 C...Key feature: tune used by the ATLAS collaboration.
58984 C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
58985 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
58986 C...Key feature: Tune A modified to use annealing CR.
58987 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
58989 C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
58990 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
58992 C...IM1 (200). Intermediate model, Q2-ordered showers.
58993 C...Key feature: new UE model with Q2-ordered showers and no interleaving.
58994 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
58995 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
58997 C...APT (201). Old UE model, pT-ordered final-state showers
58998 C...Key feature: Rick Field's Tune A, but with new final-state showers
59000 C S0 (300) and S0A (303). New UE model, pT-ordered showers.
59001 C...Key feature: large amount of multiple interactions
59002 C...* Somewhat faster than the other colour annealing scenarios.
59003 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
59004 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
59005 C...* Small amount of radiation.
59006 C...* Large amount of low-pT MI
59007 C...* Low degree of proton lumpiness (broad matter dist.)
59008 C...* CR Type S (driven by free triplets), of medium strength.
59009 C...* See: Pythia6402 update notes or later.
59011 C S1 (301). New UE model, pT-ordered showers.
59012 C...Key feature: large amount of radiation.
59013 C...* Large amount of low-pT perturbative ISR
59014 C...* Large amount of FSR off ISR partons
59015 C...* Small amount of low-pT multiple interactions
59016 C...* Moderate degree of proton lumpiness
59017 C...* Least aggressive CR type (S+S Type I), but with large strength
59018 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59020 C S2 (302). New UE model, pT-ordered showers.
59021 C...Key feature: very lumpy proton + gg string cluster formation allowed
59022 C...* Small amount of radiation
59023 C...* Moderate amount of low-pT MI
59024 C...* High degree of proton lumpiness (more spiky matter distribution)
59025 C...* Most aggressive CR type (S+S Type II), but with small strength
59026 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59028 C NOCR (304). New UE model, pT-ordered showers.
59029 C...Key feature: no colour reconnections (NB: "Best fit" only).
59030 C...* NB: <pT>(Nch) problematic in this tune.
59031 C...* Small amount of radiation
59032 C...* Small amount of low-pT MI
59033 C...* Low degree of proton lumpiness
59034 C...* Large BR composite x enhancement factor
59035 C...* Most clever colour flow without CR ("Lambda ordering")
59037 C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
59038 C...Key feature: 11-parameter ATLAS tune of the new framework.
59039 C...* Old (pre-annealing) colour reconnections a la 305.
59040 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
59042 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
59043 C...with an unmodified Pythia distribution.
59044 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
59046 C ::: + Future improvements?
59047 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
59048 C (problem: K-factor affects everything so only works as
59049 C intended for min-bias, not for UE ... probably need a
59050 C better long-term solution to handle UE as well. Anyway,
59051 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
59053 C...Global statements
59054 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59055 INTEGER PYK,PYCHGE,PYCOMP
59058 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59059 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59061 C...SCI and GAL Commonblocks
59062 COMMON /SCIPAR/MSWI(2),PARSCI(2)
59064 C...Internal parameters
59065 PARAMETER(MXTUNS=500)
59066 CHARACTER*8 CHVERS, CHDOC
59067 PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
59068 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
59069 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
59070 & CHPARJ(41:100), CH40
59073 DATA (CHNAMS(I),I=0,1)/'Default',' '/
59074 DATA (CHNAMS(I),I=100,110)/
59075 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
59076 & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
59077 DATA (CHNAMS(I),I=300,310)/
59078 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
59079 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
59080 DATA (CHNAMS(I),I=200,210)/
59081 & 'IM Tune 1','Tune APT',9*' '/
59082 DATA (CHNAMS(I),I=400,410)/
59083 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
59084 DATA (CHMSTJ(I),I=11,20)/
59085 & 'HAD choice of fragmentation function(s)',4*' ',
59086 & 'HAD treatment of small-mass systems',4*' '/
59087 DATA (CHMSTJ(I),I=41,50)/
59088 & 'FSR type (Q2 or pT) for old framework',9*' '/
59089 DATA (CHMSTP(I),I=51,100)/
59090 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
59091 6 'ISR master switch',6*' ',
59092 6 'ISR phase space choice & ME corrections',' ',
59093 7 'ISR IR regularization scheme',' ',
59094 7 'ISR scheme for FSR off ISR',8*' ',
59096 8 'UE hadron transverse mass distribution',5*' ',
59097 8 'BR composite scheme','BR colour scheme',
59098 9 'BR primordial kT compensation',
59099 9 'BR primordial kT distribution',
59100 9 'BR energy partitioning scheme',2*' ',
59101 9 'FSI colour (re-)connection model',5*' '/
59102 DATA (CHPARP(I),I=61,100)/
59103 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
59104 6 2*' ','ISR Q2max factor',3*' ',
59105 7 'FSR Q2max factor for non-s-channel procs',5*' ',
59106 7 'FSI colour reconnection turnoff scale',
59107 7 'FSI colour reconnection strength',
59108 7 'BR composite x enhancement','BR breakup suppression',
59109 8 2*'UE IR cutoff at reference ecm',
59110 8 2*'UE mass distribution parameter',
59111 8 'UE gg colour correlated fraction','UE total gg fraction',
59113 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
59114 9 'BR primordial kT width <|kT|>',' ',
59115 9 'BR primordial kT UV cutoff',7*' '/
59116 DATA (CHPARJ(I),I=41,90)/
59117 4 ' ','HAD string parameter b',8*' ',
59118 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
59120 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
59121 SAVE /PYDAT1/,/PYPARS/
59124 C...1) Shorthand notation
59127 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
59128 CHNAME=CHNAMS(ITUNE)
59129 IF (ITUNE.EQ.0) GOTO 9999
59131 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
59136 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
59138 C...3) Tune parameters
59140 C=============================================================================
59141 C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
59142 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
59143 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59144 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59145 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59154 C...UE on, new model.
59156 C...Slow IR cutoff energy scaling by default
59159 C...Switch off trial joinings
59161 C...Primordial kT cutoff
59164 C...S0 (300), S0A (303)
59165 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
59167 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59168 WRITE(M11,5030) CH60
59169 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
59170 WRITE(M11,5030) CH60
59171 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59172 WRITE(M11,5030) CH60
59174 C...Smooth ISR, low FSR
59179 C...Transverse density profile.
59182 C...Colour Reconnections
59186 C... Reference energy for pT0 and energy scaling pace.
59187 IF (ITUNE.EQ.303) PARP(90)=0.25D0
59188 C...Lambda_FSR scale.
59192 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59199 ELSEIF(ITUNE.EQ.301) THEN
59201 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59202 WRITE(M11,5030) CH60
59203 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59204 WRITE(M11,5030) CH60
59206 C...Sharp ISR, high FSR
59211 C...Colour Reconnections
59214 C...Transverse density profile.
59217 C...Lambda_FSR scale.
59221 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59228 ELSEIF(ITUNE.EQ.302) THEN
59230 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59231 WRITE(M11,5030) CH60
59232 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59233 WRITE(M11,5030) CH60
59235 C...Smooth ISR, low FSR
59240 C...Transverse density profile.
59243 C...Colour Reconnections
59246 C...Lambda_FSR scale.
59250 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59257 ELSEIF(ITUNE.EQ.304) THEN
59259 CH60='"best try" without colour reconnections'
59260 WRITE(M11,5030) CH60
59261 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59262 WRITE(M11,5030) CH60
59263 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59264 WRITE(M11,5030) CH60
59266 C...Smooth ISR, low FSR
59271 C...Transverse density profile.
59274 C...Colour Reconnections
59276 C...Lambda_FSR scale.
59280 C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
59286 C..."Lo FSR" retune (305)
59287 ELSEIF(ITUNE.EQ.305) THEN
59289 CH60='"Lo FSR retune" with primitive colour reconnections'
59290 WRITE(M11,5030) CH60
59291 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
59292 WRITE(M11,5030) CH60
59294 C...Smooth ISR, low FSR
59299 C...Transverse density profile.
59302 C...Colour Reconnections
59305 C...Lambda_FSR scale.
59309 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59317 WRITE(M11,5030) ' '
59318 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59319 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59320 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59321 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59322 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59323 WRITE(M11,5030) CH60
59324 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59325 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59326 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59327 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59328 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59329 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59330 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59331 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59332 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59333 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59334 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59335 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59336 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59337 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59338 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59339 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59340 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59343 C=============================================================================
59344 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
59345 ELSEIF (ITUNE.EQ.306) THEN
59346 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59347 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59348 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59361 C...UE on, new model.
59366 C...Switch off trial joinings
59368 C...Primordial kT cutoff
59371 CH60='see presentations by A. Moraes (ATLAS),'
59372 WRITE(M11,5030) CH60
59373 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59374 WRITE(M11,5030) CH60
59375 WRITE(M11,5030) ' '
59376 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59377 & 'externally linked and'
59378 WRITE(M11,5035) CH70
59379 CH70='MSTP(51) should be set manually according to '//
59380 & 'the library used'
59381 WRITE(M11,5035) CH70
59383 C...Smooth ISR, low FSR
59388 C...Transverse density profile.
59392 C...ISR & FSR in interactions after the first (default)
59395 C...No double-counting (default)
59397 C...Companion quark parent gluon (1-x) power
59399 C...Primordial kT compensation along chaings (default = 0 : uniform)
59401 C...Colour Reconnections
59404 C...Lambda_FSR scale.
59406 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59411 C...Peterson charm frag, and c and b hadr parameters
59417 WRITE(M11,5030) ' '
59418 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59419 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59420 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59421 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59422 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59423 WRITE(M11,5030) CH60
59424 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59425 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59426 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59427 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59428 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
59429 WRITE(M11,5030) CH60
59430 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59431 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59432 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59433 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59434 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59435 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59436 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59437 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59438 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59439 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
59440 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59441 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59442 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59443 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59444 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59445 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59446 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59447 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59450 C=============================================================================
59451 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
59452 C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
59453 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
59454 & ITUNE.EQ.109) THEN
59455 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
59456 WRITE(M11,5010) ITUNE, CHNAME
59457 CH60='see R.D. Field (CDF), in hep-ph/0610012'
59458 WRITE(M11,5030) CH60
59459 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59460 WRITE(M11,5030) CH60
59462 C...Multiple interactions on, old framework
59464 C...Fast IR cutoff energy scaling by default
59467 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
59470 IF (ITUNE.EQ.105) THEN
59473 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59481 C...Double Gaussian matter distribution.
59487 C...Lambda_FSR scale.
59489 C...Fragmentation functions and c and b parameters
59495 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
59498 c...String drawing almost completely minimizes string length.
59501 C...ISR cutoff, muR scale factor, and phase space size
59505 C...Intrinsic kT, size, and max
59509 C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
59510 IF (ITUNE.EQ.101) THEN
59517 C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
59518 ELSEIF (ITUNE.EQ.102) THEN
59521 c...String drawing completely minimizes string length.
59524 C...ISR cutoff, muR scale factor, and phase space size
59528 C...Intrinsic kT, size, and max
59534 ELSEIF (ITUNE.EQ.103) THEN
59537 c...String drawing completely minimizes string length.
59540 C...ISR cutoff, muR scale factor, and phase space size
59544 C...Intrinsic kT, size, and max
59550 ELSEIF (ITUNE.EQ.104) THEN
59553 C...Run II ref scale and slow scaling
59556 c...String drawing completely minimizes string length.
59559 C...ISR cutoff, muR scale factor, and phase space size
59563 C...Intrinsic kT, size, and max
59569 ELSEIF(ITUNE.EQ.105) THEN
59571 WRITE(M11,5030) ' '
59572 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59573 & 'externally linked and'
59574 WRITE(M11,5035) CH70
59575 CH70='MSTP(51) should be set manually according to '//
59576 & 'the library used'
59577 WRITE(M11,5035) CH70
59581 c...String drawing completely minimizes string length.
59584 C...ISR cutoff, muR scale factor, and phase space size
59588 C...Intrinsic kT, size, and max
59593 C...Tune D6 and D6T
59594 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59596 WRITE(M11,5030) ' '
59597 CH70='NB! This tune requires CTEQ6L pdfs to be '//
59598 & 'externally linked and'
59599 WRITE(M11,5035) CH70
59600 CH70='MSTP(51) should be set manually according to '//
59601 & 'the library used'
59602 WRITE(M11,5035) CH70
59604 C...The "Rick" proton, double gauss with 0.5/0.4
59608 c...String drawing completely minimizes string length.
59611 IF (ITUNE.EQ.108) THEN
59612 C...D6: pT0, Run I ref scale, and fast energy scaling
59617 C...D6T: pT0, Run II ref scale, and slow energy scaling
59622 C...ISR cutoff, muR scale factor, and phase space size
59626 C...Intrinsic kT, size, and max
59631 C...Old ATLAS-DC2 5-parameter tune
59632 ELSEIF(ITUNE.EQ.106) THEN
59634 WRITE(M11,5010) ITUNE, CHNAME
59635 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
59636 WRITE(M11,5030) CH60
59637 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59638 WRITE(M11,5030) CH60
59642 C... Different ref and rescaling pacee
59645 C... Parameters of mass distribution
59648 C... Old default string drawing
59651 C... ISR, phase space equivalent to Tune B
59666 WRITE(M11,5030) ' '
59667 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59668 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59669 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59670 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59671 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59672 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59673 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59674 WRITE(M11,5030) CH60
59675 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59676 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59677 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59678 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59679 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59680 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59681 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59682 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59683 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59684 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59685 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59686 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59687 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59688 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59689 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59690 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59691 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59694 C=============================================================================
59695 C... ACR, tune A with new CR (107)
59696 ELSEIF(ITUNE.EQ.107) THEN
59698 WRITE(M11,5010) ITUNE, CHNAME
59699 CH60='Tune A modified with new colour reconnections'
59700 WRITE(M11,5030) CH60
59701 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
59702 WRITE(M11,5030) CH60
59703 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
59704 WRITE(M11,5030) CH60
59705 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59706 WRITE(M11,5030) CH60
59707 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59708 WRITE(M11,5030) CH60
59710 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
59711 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59712 & ' with tune. Using defaults.')
59736 C...Fragmentation functions and c and b parameters
59742 WRITE(M11,5030) ' '
59743 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59744 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59745 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59746 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59747 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59748 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59749 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59750 WRITE(M11,5030) CH60
59751 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59752 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59753 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59754 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59755 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59756 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59757 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59758 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59759 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59760 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59761 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59762 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59763 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59764 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59765 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59766 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59767 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59768 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59769 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59772 C=============================================================================
59773 C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
59774 ELSEIF(ITUNE.EQ.200) THEN
59776 WRITE(M11,5010) ITUNE, CHNAME
59777 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
59778 WRITE(M11,5030) CH60
59780 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59781 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59799 C... ExpOfPow(1.8) overlap profile
59806 C... Default diquark, BR-g-BR supp
59809 C... Final state reconnect.
59812 C...Fragmentation functions and c and b parameters
59818 WRITE(M11,5030) ' '
59819 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59820 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59821 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59822 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59823 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59824 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59825 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59826 WRITE(M11,5030) CH60
59827 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59828 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59829 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59830 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59831 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59832 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59833 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59834 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59835 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59836 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59837 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59838 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59839 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59840 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59841 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59842 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59843 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59844 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59847 C...APT. Tune A modified to use new pT-ordered FSR.
59848 ELSEIF(ITUNE.EQ.201) THEN
59850 WRITE(M11,5010) ITUNE, CHNAME
59851 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
59852 WRITE(M11,5030) CH60
59853 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59854 WRITE(M11,5030) CH60
59855 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59856 WRITE(M11,5030) CH60
59857 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59858 WRITE(M11,5030) CH60
59860 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
59861 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59864 C...First set as if Pythia tune A
59865 C...Multiple interactions on, old framework
59867 C...Fast IR cutoff energy scaling by default
59870 C...Default CTEQ5L (internal)
59873 C...Double Gaussian matter distribution.
59879 c...String drawing almost completely minimizes string length.
59882 C...ISR cutoff, muR scale factor, and phase space size
59886 C...Intrinsic kT, size, and max
59890 C...Use pT-ordered FSR
59892 C...Lambda_FSR scale for pT-ordering
59896 C...Fragmentation functions and c and b parameters
59903 WRITE(M11,5030) ' '
59904 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59905 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59906 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59907 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59908 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59909 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59910 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59911 WRITE(M11,5030) CH60
59912 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
59913 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59914 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59915 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59916 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59917 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59918 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59919 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59920 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59921 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59922 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59923 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59924 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59925 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59926 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59927 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59928 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59929 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59932 C=============================================================================
59933 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
59934 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
59936 WRITE(M11,5010) ITUNE, CHNAME
59937 CH60='see J. Rathsman, PLB452(1999)364'
59938 WRITE(M11,5030) CH60
59939 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
59940 C ? WRITE(M11,5030)
59941 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59942 WRITE(M11,5030) CH60
59943 WRITE(M11,5030) ' '
59944 CH70='NB! The GAL model must be run with modified '//
59946 WRITE(M11,5035) CH70
59947 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
59948 WRITE(M11,5035) CH70
59949 WRITE(M11,5030) ' '
59951 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
59964 IF(CHNAME.EQ.'GAL Tune 1') THEN
59965 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
59971 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59972 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59973 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59974 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59975 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59979 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59980 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
59981 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59986 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59987 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
59988 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
59989 CH40='FSI SCI/GAL selection'
59990 WRITE(M11,6040) 1, MSWI(1), CH40
59991 CH40='FSI SCI/GAL sea quark treatment'
59992 WRITE(M11,6040) 2, MSWI(2), CH40
59993 CH40='FSI SCI/GAL sea quark treatment parm'
59994 WRITE(M11,6050) 1, PARSCI(1), CH40
59995 CH40='FSI SCI/GAL string reco probability R_0'
59996 WRITE(M11,6050) 2, PARSCI(2), CH40
59997 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
59998 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60000 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
60002 WRITE(M11,5010) ITUNE, CHNAME
60003 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
60004 WRITE(M11,5030) CH60
60005 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
60006 WRITE(M11,5030) CH60
60007 WRITE(M11,5030) ' '
60008 CH70='NB! The SCI model must be run with modified '//
60010 WRITE(M11,5035) CH70
60011 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
60012 WRITE(M11,5035) CH70
60013 WRITE(M11,5030) ' '
60015 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
60025 IF (CHNAME.EQ.'SCI Tune 1') THEN
60026 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
60034 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60035 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60036 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60037 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60038 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60042 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60043 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60044 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60049 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60050 CH40='FSI SCI/GAL selection'
60051 WRITE(M11,6040) 1, MSWI(1), CH40
60052 CH40='FSI SCI/GAL sea quark treatment'
60053 WRITE(M11,6040) 2, MSWI(2), CH40
60054 CH40='FSI SCI/GAL sea quark treatment parm'
60055 WRITE(M11,6050) 1, PARSCI(1), CH40
60056 CH40='FSI SCI/GAL string reco probability R_0'
60057 WRITE(M11,6050) 2, PARSCI(2), CH40
60058 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60062 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
60066 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
60070 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
60071 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
60072 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
60073 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
60074 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
60075 5030 FORMAT(' *',3x,10x,A60,3x,'*')
60076 5035 FORMAT(' *',3x,A70,3x,'*')
60077 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
60078 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
60079 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
60080 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
60081 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
60082 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
60083 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
60084 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
60085 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
60089 C*********************************************************************
60092 C...Administrates the fragmentation and decay chain.
60096 C...Double precision and integer declarations.
60097 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60098 IMPLICIT INTEGER(I-N)
60099 INTEGER PYK,PYCHGE,PYCOMP
60101 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60104 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60105 COMMON/PYINT1/MINT(400),VINT(400)
60106 COMMON/PYINT4/MWID(500),WIDS(500,5)
60107 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
60109 DIMENSION PS(2,6),IJOIN(100)
60111 C...Initialize and reset.
60113 IF(MSTU(12).NE.12345) CALL PYLIST(0)
60115 MSTU(31)=MSTU(31)+1
60119 IF(MSTU(17).LE.0) MSTU(90)=0
60122 C...Sum up momentum, energy and charge for starting entries.
60130 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
60132 PS(1,J)=PS(1,J)+P(I,J)
60134 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
60138 C...Start by all decays of coloured resonances involved in shower.
60141 IF(K(I,1).EQ.3) THEN
60143 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
60147 C...Prepare system for subsequent fragmentation/decay.
60149 IF(MINT(51).NE.0) RETURN
60151 C...Loop through jet fragmentation and particle decays.
60157 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
60160 C...Deal with any remaining undecayed resonance
60161 C...(normally the task of PYEVNT, so seldom used).
60162 ELSEIF(MWID(KC).NE.0) THEN
60164 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
60167 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
60168 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
60171 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
60172 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
60175 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
60183 IF(MINT(51).NE.0) RETURN
60185 C...Particle decay if unstable and allowed. Save long-lived particle
60186 C...decays until second pass after Bose-Einstein effects.
60187 ELSEIF(KCHG(KC,2).EQ.0) THEN
60188 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
60189 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
60192 C...Decay products may develop a shower.
60193 IF(MSTJ(92).GT.0) THEN
60195 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
60196 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
60198 CALL PYSHOW(IP1,IP1+1,QMAX)
60200 IF(MINT(51).NE.0) RETURN
60202 ELSEIF(MSTJ(92).LT.0) THEN
60205 CALL PYSHOW(IP1,-3,P(IP,5))
60207 IF(MINT(51).NE.0) RETURN
60211 C...Jet fragmentation: string or independent fragmentation.
60212 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
60214 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
60215 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
60216 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
60217 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
60218 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
60221 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
60222 IF(MFRAG.EQ.2) CALL PYINDF(IP)
60223 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
60224 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
60227 C...Loop back if enough space left in PYJETS and no error abort.
60228 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
60229 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
60231 ELSEIF(IP.LT.N) THEN
60232 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
60235 C...Include simple Bose-Einstein effect parametrization if desired.
60236 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
60241 C...Check that momentum, energy and charge were conserved.
60243 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
60245 PS(2,J)=PS(2,J)+P(I,J)
60247 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
60249 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
60250 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
60251 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
60252 &'(PYEXEC:) four-momentum was not conserved')
60253 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
60254 &'(PYEXEC:) charge was not conserved')
60259 C*********************************************************************
60262 C...Rearranges partons along strings.
60263 C...Special considerations for systems with junctions, with
60264 C...possibility of junction-antijunction annihilation.
60265 C...Allows small systems to collapse into one or two particles.
60266 C...Checks flavours and colour singlet invariant masses.
60268 SUBROUTINE PYPREP(IP)
60270 C...Double precision and integer declarations.
60271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60272 INTEGER PYK,PYCHGE,PYCOMP
60274 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60278 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60279 COMMON/PYINT1/MINT(400),VINT(400)
60280 C...The common block of colour tags.
60281 COMMON/PYCTAG/NCT,MCT(4000,2)
60282 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
60287 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
60288 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
60289 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
60290 &IJCP(0:6),TJUOLD(5)
60293 C...Function to give four-product.
60294 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)
60296 C...Rearrange parton shower product listing along strings: begin loop.
60304 DO 100 I=MAX(1,IP),N
60305 C...First store junction positions.
60306 IF(K(I,1).EQ.42) THEN
60314 DO 240 I=MAX(1,IP),N
60315 C...Special treatment for junctions
60316 IF (K(I,1).LE.0) GOTO 240
60317 IF(K(I,1).EQ.42) THEN
60318 C...MQGST=2: Look for junction-junction strings (not detected in the
60319 C...main search below).
60320 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
60321 IF (NJJSTR.EQ.0) THEN
60322 NJJSTR = (3*NJUNC-NPIECE)/2
60324 C...Check how many already identified strings end on this junction
60327 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
60329 C...If less than 3, remaining must be to another junction
60332 C...Multiple j-j connections not handled yet.
60334 & '(PYPREP:) Too many junction-junction strings.')
60338 C...The colour information in the junction is unreadable for the
60339 C...colour space search further down in this routine, so we must
60340 C...start on the colour mother of this junction and then "artificially"
60341 C...prevent the colour mother from connecting here again.
60342 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
60344 IF (MOD(ITJUNC,2).EQ.0) KCS=5
60345 C...Switch colour if the junction-junction leg is presumably a
60346 C...junction mother leg rather than a junction daughter leg.
60347 IF (ITJUNC.GE.3) KCS=9-KCS
60348 IF (MINT(33).EQ.0) THEN
60349 C...Find the unconnected leg and reorder junction daughter pointers so
60350 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
60352 IA=MOD(K(I,4),MSTU(5))
60353 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
60354 ITMP=MOD(K(I,5),MSTU(5))
60355 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
60356 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
60357 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
60359 K(I,5)=K(I,5)+(IA-ITMP)
60361 K(I,4)=K(I,4)+(ITMP-IA)
60364 IF (ITJUNC.LE.2) THEN
60365 C...Beam baryon junction
60366 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
60367 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
60368 C...Else 1 -> 2 decay junction
60370 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
60371 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
60376 C...Alternatively use colour tag information.
60378 C...Find a final state parton with appropriate dangling colour tag.
60382 DO 140 J1=MAX(1,IP),N
60383 IF (K(J1,1).NE.3) GOTO 140
60384 C...Check for matching final-state colour tag
60386 DO 120 J2=MAX(1,IP),N
60387 IF (K(J2,1).NE.3) GOTO 120
60388 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
60390 IF (IMATCH.EQ.1) GOTO 140
60391 C...Check whether this colour tag belongs to the present junction
60392 C...by seeing whether any parton with this colour tag has the same
60393 C...mother as the junction.
60396 DO 130 J2=MINT(84)+1,N
60398 C...First scattering partons have IMO1 = 3 and 4.
60399 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
60401 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
60404 IF (IMATCH.EQ.0) GOTO 140
60407 C...Check for junction-junction strings without intermediate final state
60408 C...glue (not detected above).
60412 IF (IJU2.EQ.I) GOTO 160
60413 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
60414 C...Only opposite types of junctions can connect to each other.
60415 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
60418 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
60420 IF (IS.EQ.3) GOTO 160
60425 C...Switch to other side of adjacent parton and step from there.
60431 ELSE IF (ILC.NE.3) THEN
60436 C...Look for coloured string endpoint, or (later) leftover gluon.
60437 IF(K(I,1).NE.3) GOTO 240
60439 IF(KC.EQ.0) GOTO 240
60441 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
60443 C...Pick up loose string end.
60445 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
60451 IF(NSTP.GT.4*N) THEN
60452 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
60457 C...Copy undecayed parton. Finished if reached string endpoint.
60458 IF(K(IA,1).EQ.3) THEN
60459 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
60460 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60467 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
60477 IF(K(I1,1).EQ.1) GOTO 240
60480 C...Also finished (for now) if reached junction; then copy to end.
60481 IF(K(IA,1).EQ.42) THEN
60483 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
60484 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60489 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
60490 DO 200 ICOPY=1,NCOPY
60492 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
60493 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
60494 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
60498 C...For junction-junction strings, find end leg and reorder junction
60499 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
60500 C...junction-junction string piece.
60501 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
60502 ITMP=MOD(K(IA,4),MSTU(5))
60503 IF (ITMP.NE.IB) THEN
60504 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
60505 K(IA,5)=K(IA,5)+(ITMP-IB)
60507 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
60509 K(IA,4)=K(IA,4)+(IB-ITMP)
60514 C...0: endpoint in original ER
60517 C...3: Parton immediately next to junction
60520 IPIECE(NPIECE,1)=MSTU32+1
60521 IPIECE(NPIECE,2)=MSTU32+NCOPY
60522 IPIECE(NPIECE,3)=IB
60523 IPIECE(NPIECE,4)=IA
60524 MSTU32=MSTU32+NCOPY
60529 C...GOTO next parton in colour space.
60531 IF (MINT(33).EQ.0) THEN
60532 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
60534 IA=MOD(K(IB,KCS),MSTU(5))
60535 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
60538 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
60539 & MSTU(5)).EQ.0) KCS=9-KCS
60540 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
60541 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
60544 IF(IA.LE.0.OR.IA.GT.N) THEN
60545 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
60546 IF(NERRPR.LT.5) THEN
60548 WRITE(MSTU(11),*) 'started at:', I
60549 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
60550 WRITE(MSTU(11),*) 'MQGST =',MQGST
60556 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
60557 & ,MSTU(5)).EQ.IB) THEN
60558 IF(MREV.EQ.1) KCS=9-KCS
60559 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
60560 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
60562 IF(MREV.EQ.0) KCS=9-KCS
60563 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
60564 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
60566 IF(IA.NE.I) GOTO 170
60567 C...Use colour tag information
60569 C...First create colour tags starting on IB if none already present.
60570 IF (MCT(IB,KCS-3).EQ.0) THEN
60571 CALL PYCTTR(IB,KCS,IB)
60572 IF(MINT(51).NE.0) RETURN
60576 C...Find final state tag partner
60577 DO 210 IT=MAX(1,IP),N
60578 IF (IT.EQ.IB) GOTO 210
60579 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
60585 C...Just copy and goto next if exactly one partner found.
60586 IF (IFOUND.EQ.1) THEN
60588 C...When no match found, match is presumably junction.
60589 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
60590 C...Check whether this colour tag matches a junction
60591 C...by seeing whether any parton with this colour tag has the same
60592 C...mother as a junction.
60593 C...NB: Only type 1 and 2 junctions handled presently.
60595 IJUMO=K(IJUNC(IJU,0),3)
60596 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
60597 C...Colours only connect to junctions, anti-colours to antijunctions:
60598 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
60600 DO 220 J1=MAX(1,IP),N
60601 IF (K(J1,1).LE.0) GOTO 220
60602 C...First scattering partons have IMO1 = 3 and 4.
60604 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
60606 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
60607 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
60609 C...Attempt at handling type > 3 junctions also. Not tested.
60610 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
60613 IF (IMATCH.EQ.0) GOTO 230
60618 IF (IFOUND.EQ.1) THEN
60620 ELSEIF (IFOUND.EQ.0) THEN
60622 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
60624 IF(NERRPR.LT.5) THEN
60631 ELSEIF (IFOUND.GE.2) THEN
60634 & ,'(PYPREP:) too many occurences of colour line: '//
60636 IF(NERRPR.LT.5) THEN
60648 C...Junction systems remain.
60654 260 IJUCNT=IJUCNT+1
60655 IF (IJUCNT.LE.NJUNC) THEN
60656 C...If we are not processing a j-j string, treat this junction as new.
60657 IF (IJJSTR.EQ.0) THEN
60658 IJU=IJUNC(IJUCNT,0)
60660 C...If junction has already been read, ignore it.
60661 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
60662 C...If we are on a j-j string, goto second j-j junction.
60667 C...Mark selected junction read.
60669 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
60671 C...Determine junction type
60672 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
60673 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
60674 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
60675 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
60676 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
60679 C...Find which quarks belong to given junction.
60681 DO 290 IPC=1,NPIECE
60682 IF (IPIECE(IPC,4).EQ.IJU) THEN
60684 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
60686 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
60688 C...IHK = 3 is special. Either normal string piece, or j-j string.
60690 IF (MREV.NE.1) THEN
60691 DO 300 IPC=1,NPIECE
60692 C...If there is a j-j string starting on the present junction which has
60693 C...zero length, insert next junction immediately.
60694 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
60695 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
60701 C...If MREV is 1 and IHK is 3 we are finished with this system.
60708 C...If we've gotten this far, then either IHK < 3, or
60709 C...an interjunction string exists, or just a third normal string.
60710 IJUNC(IJUCNT,IHK)=0
60712 C..Order pieces belonging to this junction. Also look for j-j.
60713 DO 310 IPC=1,NPIECE
60714 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
60715 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
60716 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
60717 IJUNC(IJUCNT,IHK)=IPC
60722 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
60723 IPC=IJUNC(IJUCNT,IHK)
60724 C...Temporary solution to cover for bug.
60726 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
60730 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
60733 K(I1,J)=K(MSTU(4)-ICP,J)
60734 P(I1,J)=P(MSTU(4)-ICP,J)
60735 V(I1,J)=V(MSTU(4)-ICP,J)
60739 C...Mark last quark.
60740 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
60741 C...Do not insert junctions at wrong places.
60742 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
60743 C...Insert junction.
60746 C...Shift to end junction if a j-j string has been processed.
60747 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
60757 K(IJUS,1)=K(IJUS,1)+10
60760 360 IF (IHK.LT.3) GOTO 280
60762 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
60766 IF (IJUCNT.NE.NJUNC) GOTO 260
60770 C...Rearrange three strings from junction, e.g. in case one has been
60771 C...shortened by shower, so the last is the largest-energy one.
60772 IF(NJUNC.GE.1) THEN
60773 C...Find systems with exactly one junction.
60777 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
60778 ELSEIF(K(I,1).EQ.41) THEN
60780 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
60785 C...Sum up energy-momentum in each junction string.
60792 DO 390 I1=NBEG,NEND
60793 IF(K(I1,2).NE.21) THEN
60798 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
60801 C...Find which of them has highest energy (minus mass) in rest frame.
60803 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
60805 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
60808 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
60809 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
60811 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
60812 C...Decide how to rearrange so that new last has highest energy.
60813 IF(PJU(1,6).LT.PJU(2,6)) THEN
60815 IRNG(1,2)=IJUR(2)-1
60817 IRNG(2,2)=IJUR(3)+1
60818 IRNG(4,1)=IJUR(3)-1
60822 IRNG(1,2)=IJUR(3)+1
60824 IRNG(2,2)=IJUR(3)-1
60825 IRNG(4,1)=IJUR(2)-1
60830 C...Copy in correct order below bottom of current event record.
60833 DO 430 I1=IRNG(II,1),IRNG(II,2),
60834 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
60836 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
60838 & '(PYPREP:) no more memory left in PYJETS')
60848 IF(K(I2,1).EQ.1) K(I2,1)=2
60852 C...Copy back up, overwriting but now in correct order.
60853 DO 460 I1=NBEG,NEND
60867 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
60868 C...to two q-qbar systems.
60869 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
60870 IF (MSTJ(19).NE.1) THEN
60874 C...Force collapse when MSTJ(19)=2.
60875 IF (MSTJ(19).EQ.2) THEN
60879 C...Find systems with exactly two junctions.
60881 C...Count junctions
60882 IF (K(I,1).EQ.41) THEN
60884 C...Check for interjunction gluons
60885 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
60888 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
60889 C...If end of system reached with either zero or one junction, restart
60890 C...with next system.
60894 ELSEIF(K(I,1).EQ.1) THEN
60895 C...If end of system reached with exactly two junctions, compute string
60896 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
60897 C...length measure for the (q-qbar)(q-qbar) topology.
60899 C...Loop down through chain.
60901 DO 480 I1=NBEG,NEND
60902 C...Store string piece division locations in event record
60903 IF (K(I1,2).NE.21) THEN
60908 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
60910 IF (PYR(0).LT.0.5D0) ISW=1
60911 C...Randomly choose which qqbar string gets the jj gluons.
60913 IF (PYR(0).GT.0.5D0) IGS=2
60914 C...Only compute string lengths when no topology forced.
60915 IF (MSTJ(19).EQ.0) THEN
60916 C...Repeat following for each junction
60918 C...Initialize iterative procedure for finding JRF
60924 C...Start iteration. Sum up momenta in string pieces
60926 C...JD=-1 for first junction, +1 for second junction.
60927 C...Find out where piece starts and ends and which direction to go.
60930 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
60931 IB = IJCP((IJU-1)*7 - JD*IJS)
60932 ELSEIF (IJS.EQ.3) THEN
60934 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
60935 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
60937 C...Initialize junction pull 4-vector.
60941 C...Initialize weight
60944 C...Sum up (weighted) momenta along each string piece
60945 DO 530 ISP=IA,IB,JD
60946 C...If present parton not last in chain
60947 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
60948 C...If last parton was a junction, store present weight
60949 IF (K(ISP-JD,2).EQ.88) THEN
60951 C...If last parton was a quark, reset to stored weight.
60952 ELSEIF (K(ISP-JD,2).NE.21) THEN
60956 C...Skip next parton if weight already large
60957 IF (PWT.GT.10D0) GOTO 530
60958 C...Compute momentum in TJUOLD frame:
60959 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
60961 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
60963 TMP=P(ISP,J)+TJUOLD(J)*BFC
60964 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
60967 TMP=TJUOLD(4)*P(ISP,4)+TDP
60968 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
60970 PWT=PWT+TMP/PARJ(48)
60971 C...Put |p| rather than m in 5th slot
60972 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
60979 C...Combine new boost (T) with old boost (TJUOLD)
60980 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
60982 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
60985 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
60987 C...If last boost small, accept JRF, else iterate.
60988 C...Also prevent possibility of infinite loop.
60989 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
60990 & IJRFIT.LT.MSTJ(18))THEN
60992 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
60993 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
60995 C...Store final boost, with change of sign since TJJ motion vector.
60997 TJJ(IJU,IX)=-TJUOLD(IX)
60999 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
61002 C...String length measure for (q-qbar)(q-qbar) topology.
61003 C...Note only momenta of nearest partons used (since rest of system
61005 IF (JJGLUE.EQ.0) THEN
61006 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
61007 & -1,IJCP(5-ISW)+1)
61009 C...Put jj gluons on selected string (IGS selected randomly above).
61011 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61012 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
61014 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
61015 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61019 C...String length measure for q-q-j-j-q-q topology.
61028 C...Note only momenta of nearest partons used (since rest of system
61031 IF (IX.EQ.4) ISGN=1
61032 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
61033 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
61034 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
61035 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
61036 IF (JJGLUE.EQ.0) THEN
61037 C...Junction motion vector dot product gives length when inter-junction
61039 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
61041 C...Junction motion vector dot products with gluon momenta give length
61042 C...when inter-junction gluons present.
61043 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
61044 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
61047 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
61048 IF (JJGLUE.EQ.0) THEN
61049 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
61051 DELMJJ=DELMJJ*4D0*T1G1*T2G2
61054 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
61055 C...(Always the case for MSTJ(19)=2 due to initialization above)
61056 IF (DELMJJ.GT.DELMQQ) THEN
61057 C...Put new system at end of event record
61060 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
61063 P(NCOP,IX)=P(ICOP,IX)
61064 K(NCOP,IX)=K(ICOP,IX)
61067 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
61068 C...Insert inter-junction gluon string piece (reversed)
61070 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
61074 P(NCOP,IX)=P(ICOP,IX)
61075 K(NCOP,IX)=K(ICOP,IX)
61080 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
61083 P(NCOP,IX)=P(ICOP,IX)
61084 K(NCOP,IX)=K(ICOP,IX)
61089 C...Copy system back in right order
61090 DO 670 ICOP=NBEG,NEND-2
61092 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
61093 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
61096 C...Shift down rest of event record
61097 DO 690 ICOP=NEND+1,N
61099 P(ICOP-2,IX)=P(ICOP,IX)
61100 K(ICOP-2,IX)=K(ICOP,IX)
61103 C...Update length of event record.
61113 C...Done if no checks on small-mass systems.
61114 IF(MSTJ(14).LT.0) RETURN
61115 IF(MSTJ(14).EQ.0) GOTO 1140
61117 C...Find lowest-mass colour singlet jet system.
61122 DO 770 I=MAX(1,IP),N
61123 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
61124 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
61131 DPS(5)=PYMASS(K(I,2))
61132 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
61134 DPS(J)=DPS(J)+P(I,J)
61137 DPS(5)=DPS(5)+PYMASS(K(I,2))
61138 ELSEIF(K(I,1).EQ.2) THEN
61140 DPS(J)=DPS(J)+P(I,J)
61142 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61144 DPS(J)=DPS(J)+P(I,J)
61147 DPS(5)=DPS(5)+PYMASS(K(I,2))
61148 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
61150 IF(PD.LT.PDMIN) THEN
61164 C...Done if lowest-mass system above threshold for string frag.
61165 IF(PDMIN.GE.PARJ(32)) GOTO 1140
61167 C...Fill small-mass system as cluster.
61169 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
61179 C...Set up history, assuming cluster -> 2 hadrons.
61185 IF(MSTU(16).NE.2) THEN
61200 C...Find total flavour content - complicated by presence of junctions.
61204 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
61207 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
61211 C...If several diquarks, split up one to give even number of flavours.
61212 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
61214 IF(IABS(KFQ(3)).LT.1000) I1=1
61215 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
61216 KFQ(I1)=KFQ(I1)/1000
61221 C...If four quark ends, join two to diquark.
61222 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
61225 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
61226 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
61227 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61228 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61229 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61230 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61236 C...If two quark ends, plus quark or diquark, join quarks to diquark.
61240 IF(IABS(KFQ(I1)).GT.1000) I1=3
61241 IF(IABS(KFQ(I2)).GT.1000) I2=3
61242 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61243 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61244 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61245 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61251 C...Form two particles from flavours of lowest-mass system, if feasible.
61253 790 NTRY = NTRY + 1
61255 C...Open string with two specified endpoint flavours.
61259 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
61260 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61261 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61262 IF(KQ1+KQ2.NE.0) GOTO 1140
61263 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
61265 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
61267 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
61268 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
61269 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
61271 C...Open string with four specified flavours.
61272 ELSEIF(NQ.EQ.4) THEN
61277 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
61278 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61279 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61280 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
61281 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
61282 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
61283 C...Combine flavours pairwise to form two hadrons.
61286 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61287 & IABS(KFQ(2)).GT.1000)) I2=3
61288 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61289 & IABS(KFQ(3)).GT.1000))) I2=4
61293 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
61294 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
61295 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
61299 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
61300 C...No room for popcorn mesons in closed string -> 2 hadrons.
61302 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
61303 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
61304 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
61305 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
61307 P(N+2,5)=PYMASS(K(N+2,2))
61308 P(N+3,5)=PYMASS(K(N+3,2))
61310 C...If it does not work: try again (a number of times), give up (if no
61311 C...place to shuffle momentum or too many flavours), or form one hadron.
61312 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
61313 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
61315 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
61322 C...Perform two-particle decay of jet system.
61323 C...First step: find reference axis in decaying system rest frame.
61324 C...(Borrow slot N+2 for temporary direction.)
61328 DO 850 I=IC1+1,IC2-1
61329 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61330 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61331 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
61333 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
61337 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
61339 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
61340 PHI1=PYANGL(P(N+2,1),P(N+2,2))
61342 C...Second step: generate isotropic/anisotropic decay.
61343 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
61344 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
61346 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
61347 PT2=(1D0-UE(3)**2)*PA**2
61348 IF(MSTJ(16).LE.0) THEN
61351 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
61352 PR1=P(N+2,5)**2+PT2
61353 PR2=P(N+3,5)**2+PT2
61354 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
61356 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61357 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
61359 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
61361 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
61362 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
61367 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
61368 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
61370 C...Third step: move back to event frame and set production vertex.
61371 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
61381 C...Else form one particle, if possible.
61389 C...Select hadron flavour from available quark flavours.
61390 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
61392 ELSEIF(NQ.EQ.2) THEN
61393 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
61395 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
61396 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
61398 IF(K(N+2,2).EQ.0) GOTO 910
61399 P(N+2,5)=PYMASS(K(N+2,2))
61401 C...Use old algorithm for E/p conservation? (EN)
61402 IF (MSTJ(16).LE.0) GOTO 1080
61404 C...Find the string piece closest to the cluster by a loop
61405 C...over the undecayed partons not in present cluster. (EN)
61410 DO 940 I1=MAX(1,IP),N-1
61411 IF(K(I1,1).EQ.1) NJUNC=0
61412 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
61413 IF(K(I1,1).EQ.41) GOTO 940
61414 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
61416 ELSEIF(K(I1,1).EQ.2) THEN
61420 IF(K(I2,1).EQ.41) GOTO 940
61421 IF(K(I2,1).GT.10) GOTO 920
61422 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
61423 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
61424 & NJUNC.EQ.0) GOTO 940
61425 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
61426 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
61427 & K(I2,1).NE.1)) GOTO 940
61429 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
61431 E1(J)=P(I1,J)/P(I1,4)
61432 E2(J)=P(I2,J)/P(I2,4)
61433 ECL(J)=P(N+1,J)/P(N+1,4)
61438 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
61439 E3S=E3(1)**2+E3(2)**2+E3(3)**2
61440 E4S=E4(1)**2+E4(2)**2+E4(3)**2
61441 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
61442 IF(E34.LE.0D0) THEN
61444 ELSEIF(E34.LT.E3S) THEN
61445 DDMIN=E4S-E34**2/E3S
61447 DDMIN=E4S-2D0*E34+E3S
61450 C...Is this the smallest so far?
61451 IF(DDMIN.LT.DGLOMI) THEN
61456 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
61461 C... Check if there are any strings to connect to the new gluon. (EN)
61462 IF (IBEG.EQ.0) GOTO 1080
61464 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
61465 IF (P(N+1,5).GE.P(N+2,5)) THEN
61467 C...Construct 'gluon' that is needed to put hadron on the mass shell.
61468 FRAC=P(N+2,5)/P(N+1,5)
61470 P(N+2,J)=FRAC*P(N+1,J)
61471 PG(J)=(1D0-FRAC)*P(N+1,J)
61474 C... Copy string with new gluon put in.
61478 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
61479 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
61500 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
61503 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
61504 C...from string piece endpoints.
61507 C...Begin by copying string that should give energy to cluster.
61511 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
61512 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
61524 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
61527 C...Set initial Phad.
61529 P(NSAV+2,J)=P(NSAV+1,J)
61532 C...Calculate Pg, a part of which will be added to Phad later. (EN)
61533 1020 IF(MSTJ(16).EQ.1) THEN
61537 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
61538 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
61541 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
61543 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
61545 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
61546 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
61548 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
61549 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
61550 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
61552 C...If all gluon energy eaten, zero it and take a step back.
61554 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
61557 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
61563 IF(K(I1,1).EQ.41) ITER=-1
61565 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
61568 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
61574 IF(K(I2,1).EQ.41) ITER=-1
61576 IF(ITER.EQ.1) GOTO 1020
61578 C...If also all endpoint energy eaten, revert to old procedure.
61579 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
61580 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
61591 C... Construct the collapsed hadron and modified string partons.
61593 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
61594 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
61595 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
61597 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
61598 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
61600 C...Finished with string collapse in new scheme.
61604 C... Use old algorithm; by choice or when in trouble.
61606 C...Find parton/particle which combines to largest extra mass.
61611 IF(IR.NE.0) GOTO 1100
61612 DO 1090 I=MAX(1,IP),N
61613 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
61614 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
61615 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
61616 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
61617 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
61618 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
61620 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
61621 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
61622 IF(HSR.GT.HSM) THEN
61630 C...Shuffle energy and momentum to put new particle on mass shell.
61635 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
61636 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
61637 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
61639 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
61640 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
61644 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
61648 C...Mark collapsed system and store daughter pointers. Iterate.
61649 1120 DO 1130 I=IC1,IC2
61650 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61651 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61653 IF(MSTU(16).NE.2) THEN
61658 K(I,5)=NSAV+1+NBODY
61661 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
61663 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
61665 C...Check flavours and invariant masses in parton systems.
61673 DO 1180 I=MAX(1,IP),N
61674 IF(K(I,1).EQ.41) NJU=NJU+1
61675 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
61677 IF(KC.EQ.0) GOTO 1180
61678 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61679 IF(KQ.EQ.0) GOTO 1180
61685 DPS(5)=DPS(5)+PYMASS(K(I,2))
61688 DPS(J)=DPS(J)+P(I,J)
61690 IF(K(I,1).EQ.1) THEN
61692 IF(NJU.EQ.0.AND.NP.NE.1) THEN
61693 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
61694 ELSEIF(NJU.EQ.1) THEN
61695 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
61696 ELSEIF(NJU.EQ.2) THEN
61697 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
61698 ELSEIF(NJU.GE.3) THEN
61701 IF(NFERR.EQ.1) THEN
61702 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
61706 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
61707 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
61708 & '(PYPREP:) too small mass in jet system')
61722 C*********************************************************************
61725 C...Handles the fragmentation of an arbitrary colour singlet
61726 C...jet system according to the Lund string fragmentation model.
61728 SUBROUTINE PYSTRF(IP)
61730 C...Double precision and integer declarations.
61731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61732 IMPLICIT INTEGER(I-N)
61733 INTEGER PYK,PYCHGE,PYCOMP
61735 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61738 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61739 C...Local arrays. All MOPS variables ends with MO
61740 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
61741 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
61742 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
61743 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
61744 &PBST(3,5),TJUOLD(5)
61746 C...Function: four-product of two vectors.
61747 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)
61748 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
61751 C...Reset counters.
61766 C...Identify parton system.
61769 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61770 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
61771 IF(MSTU(21).GE.1) RETURN
61773 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
61775 IF(KC.EQ.0) GOTO 110
61776 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61777 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
61778 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
61779 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61780 IF(MSTU(21).GE.1) RETURN
61783 C...Take copy of partons to be considered. Check flavour sum.
61788 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
61790 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
61792 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61793 IF(K(I,1).EQ.41) THEN
61794 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
61802 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
61803 IF(MOD(KQSUM,3).NE.0) THEN
61804 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
61805 IF(MSTU(21).GE.1) RETURN
61807 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
61809 C...Boost copied system to CM frame (for better numerical precision).
61810 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
61813 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
61817 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
61819 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61820 IF(P(I,3).GT.0D0) THEN
61821 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
61822 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61823 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61825 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
61826 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61827 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61832 C...Search for very nearby partons that may be recombined.
61841 IF(MJU(1).GT.0) NRMIN=NRMIN+2
61842 IF(MJU(2).GT.0) NRMIN=NRMIN+2
61843 140 IF(NR.GT.NRMIN) THEN
61846 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
61848 IF(I.EQ.N+NR) I1=N+1
61849 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
61850 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
61852 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
61854 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
61855 & P(I1,2)**2+P(I1,3)**2))
61856 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
61857 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
61858 IF(PDR.LT.PDRMIN) THEN
61864 C...Recombine very nearby partons to avoid machine precision problems.
61865 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
61867 P(N+1,J)=P(N+1,J)+P(N+NR,J)
61869 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
61873 ELSEIF(PDRMIN.LT.PARU12) THEN
61875 P(IR,J)=P(IR,J)+P(IR+1,J)
61877 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
61879 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
61880 DO 190 I=IR+1,N+NR-1
61887 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
61889 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
61890 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
61896 C...Reset particle counter. Skip ahead if no junctions are present;
61897 C...this is usually the case!
61898 NRS=MAX(5*NR+11,NP)
61901 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61905 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
61906 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61907 IF(MSTU(21).GE.1) RETURN
61911 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
61912 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
61913 & ' junction strings not handled by MSTJ(12)>3 options')
61916 IF(MJU(JT).EQ.0) GOTO 640
61920 C...Find and sum up momentum on three sides of junction.
61921 C...Begin with previous boost = zero.
61928 C...Beginning and end of string system in event record.
61929 I1BEG=N+1+(JT-1)*(NR-1)
61930 I1END=N+NR+(JT-1)*(1-NR)
61931 C...Look for junction string piece end points
61932 DO 230 I1=I1BEG,I1END,JS
61933 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
61934 C...Store junction string piece end points.
61935 C 1-junction systems 2-junction systems
61936 C IU : 1 2 3 4 1 2 3 4 5 6
61937 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
61941 C...Sum over momenta, from junction outwards.
61945 C...Initialize junction drag and string piece 4-vectors.
61950 C...First two branches. Inwards out means opposite direction to JS.
61951 C...(JS is 1 for JT=1, -1 for JT=2)
61956 C...Last branch (gq or gjgqgq). Direction now reversed.
61962 DO 270 I1=I1A,I1B,IDIR
61963 C...Sum up momentum directions with exponential suppression
61964 C...for use in finding junction rest frame below.
61965 IF (K(I1,2).EQ.88) THEN
61966 C...gjgqgq type system encountered. Use current PWT as start
61967 C...for both strings.
61970 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
61971 C...Sum up string piece (boosted) 4-momenta.
61973 PJU(IU,J)=PJU(IU,J)+P(I1,J)
61975 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
61976 C...boost is zero, see above). Skip parton if suppression factor large.
61977 IF (PWT.GT.10D0) GOTO 270
61978 C...Compute momentum in current frame:
61979 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
61980 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
61982 PTMP=P(I1,J)+TJUOLD(J)*BFC
61983 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
61986 PTMP=TJUOLD(4)*P(I1,4)+TDP
61987 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
61988 PWT=PWT+PTMP/PARJ(48)
61991 C...Put |p| rather than m in 5th slot.
61992 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
61993 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
61996 C...Calculate boost from present frame to next JRF candidate.
61998 CALL PYJURF(PBST,TJU)
62000 C...After some iterations do not take full step in new direction.
62001 IF(IJRFIT.GT.5) THEN
62002 REDUCE=0.8D0**(IJRFIT-5)
62003 TJU(1)=REDUCE*TJU(1)
62004 TJU(2)=REDUCE*TJU(2)
62005 TJU(3)=REDUCE*TJU(3)
62006 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62009 C...Combine new boost (TJU) with old boost (TJUOLD)
62010 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
62012 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
62014 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
62016 C...If last boost small, accept JRF, else iterate.
62017 C...Also prevent possibility of infinite loop.
62018 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
62019 & IJRFIT.LT.MSTJ(18)) THEN
62021 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
62022 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
62025 C...Now store total boost in TJU and change perception.
62026 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
62027 C...TJU = junction motion vector in string CM, so the sign changes.
62031 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62035 C...Calculate string piece energies in junction rest frame.
62037 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
62039 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
62040 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
62043 C...Start preparing for fragmentation of two strings from junction.
62046 320 NTRYER=NTRYER+1
62049 NS=IABS(IJU(IU+1)-IJU(IU))
62051 C...Junction strings: find longitudinal string directions.
62053 IS1=IJU(IU)+JS*(IS-1)
62056 DP(1,J)=0.5D0*P(IS1,J)
62057 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
62058 DP(2,J)=0.5D0*P(IS2,J)
62059 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
62060 & (PJU(IU,5)/PBST(IU,5))
62062 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
62063 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
62067 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
62068 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62069 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62074 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62075 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62076 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62078 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62080 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62081 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62085 C...Junction strings: initialize flavour, momentum and starting pos.
62089 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62093 ELSEIF(NTRY.GT.100) THEN
62094 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62095 IF(MSTU(21).GE.1) RETURN
62100 IE(1)=K(N+1+(JT/2)*(NP-1),3)
62101 IF (MOD(JT+IU,2).NE.0) THEN
62103 IF (NP-NR.NE.0) THEN
62104 C...If gluons have disappeared. Original IJU must be used.
62108 IF (K(IT,2).NE.21) THEN
62111 IF (NE.EQ.IU+4*(JT-1)) THEN
62113 ELSEIF (IT.LE.IP+NP) THEN
62116 CALL PYERRM(14,'(PYSTRF:) '//
62117 & 'Original IJU could not be reconstructed!')
62125 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
62131 KFL(1)=K(IJU(IU),2)
62139 C...Junction strings: find initial transverse directions.
62142 DP(2,J)=P(IN(4)+1,J)
62146 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62147 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62148 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62149 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62150 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62151 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62152 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62153 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62154 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62156 DHCX1=DFOUR(3,1)/DHC12
62157 DHCX2=DFOUR(3,2)/DHC12
62158 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62159 DHCY1=DFOUR(4,1)/DHC12
62160 DHCY2=DFOUR(4,2)/DHC12
62161 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62162 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62164 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62166 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62170 C...Junction strings: produce new particle, origin.
62172 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62173 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62174 IF(MSTU(21).GE.1) RETURN
62182 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
62183 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
62184 IF(K(I,2).EQ.0) GOTO 360
62185 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
62186 & IABS(KFL(3)).GT.10) THEN
62187 IF(PYR(0).GT.PARJ(19)) GOTO 440
62189 P(I,5)=PYMASS(K(I,2))
62190 CALL PYPTDI(KFL(1),PX(3),PY(3))
62191 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
62192 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
62193 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
62194 & MSTU(90).LT.8) THEN
62195 MSTU(90)=MSTU(90)+1
62196 MSTU(90+MSTU(90))=I
62197 PARU(90+MSTU(90))=Z
62199 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
62204 C...Junction strings: stepping within 'low' string region.
62205 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62206 & P(IN(1),5)**2.GE.PR(1)) THEN
62207 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
62208 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
62210 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
62213 C...Has used up energy of junction string, i.e. no more hadrons in it.
62214 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
62219 C...Stepping from 'low' string region
62220 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62221 P(IN(2)+2,4)=P(IN(2)+2,3)
62224 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62225 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62226 P(IN(1)+2,4)=P(IN(1)+2,3)
62232 C...Junction strings: find new transverse directions.
62233 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
62234 & IN(1).GT.IN(2)) GOTO 360
62235 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
62242 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62243 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62245 IF(DHC12.LE.1D-2) THEN
62246 P(IN(1)+2,4)=P(IN(1)+2,3)
62252 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62253 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62254 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62255 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62256 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62257 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62258 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62259 DHCX1=DFOUR(3,1)/DHC12
62260 DHCX2=DFOUR(3,2)/DHC12
62261 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62262 DHCY1=DFOUR(4,1)/DHC12
62263 DHCY2=DFOUR(4,2)/DHC12
62264 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62265 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62267 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62269 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62272 C...Express pT with respect to new axes, if sensible.
62273 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
62274 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
62275 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62281 C...Junction strings: sum up known four-momentum, coefficients for m2.
62284 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
62285 & PY(3)*P(IN(3)+1,J)
62286 DO 510 IN1=IN(4),IN(1)-4,4
62287 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62289 DO 520 IN2=IN(5),IN(2)-4,4
62290 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62294 DHM(2)=2D0*FOUR(I,IN(1))
62295 DHM(3)=2D0*FOUR(I,IN(2))
62296 DHM(4)=2D0*FOUR(IN(1),IN(2))
62298 C...Junction strings: find coefficients for Gamma expression.
62299 DO 550 IN2=IN(1)+1,IN(2),4
62300 DO 540 IN1=IN(1),IN2-1,4
62301 DHC=2D0*FOUR(IN1,IN2)
62302 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
62303 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
62304 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
62305 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62309 C...Junction strings: solve (m2, Gamma) equation system for energies.
62310 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
62311 IF(ABS(DHS1).LT.1D-4) GOTO 360
62312 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
62313 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
62314 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
62315 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62316 & ABS(DHS1)-DHS2/DHS1)
62317 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
62318 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
62319 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
62321 C...Junction strings: step to new region if necessary.
62322 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
62323 P(IN(2)+2,4)=P(IN(2)+2,3)
62326 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62327 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62328 P(IN(1)+2,4)=P(IN(1)+2,3)
62333 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
62334 P(IN(1)+2,4)=P(IN(1)+2,3)
62340 C...Junction strings: particle four-momentum, remainder, loop back.
62342 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
62343 & P(IN(2)+2,4)*P(IN(2),J)
62344 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
62346 IF(P(I,4).LT.P(I,5)) GOTO 360
62347 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62348 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62349 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
62354 IF(IN(3).NE.IN(6)) THEN
62356 P(IN(6),J)=P(IN(3),J)
62357 P(IN(6)+1,J)=P(IN(3)+1,J)
62362 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62363 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
62368 C...Junction strings: save quantities left after each string.
62369 IF(IABS(KFL(1)).GT.10) GOTO 360
62373 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
62376 C...Junction strings: loopback if much unused energy in both strings.
62377 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62378 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62379 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
62381 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
62382 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
62383 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
62384 & .AND.NTRYER.LT.10) GOTO 320
62386 C...Junction strings: put together to new effective string endpoint.
62388 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
62389 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
62390 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
62391 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
62393 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
62394 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
62396 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
62401 C...Open versus closed strings. Choose breakup region for latter.
62402 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
62405 ELSEIF(MJU(1).NE.0) THEN
62408 ELSEIF(MJU(2).NE.0) THEN
62411 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
62418 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
62419 W2SUM=W2SUM+P(N+NR+IS,1)
62424 W2SUM=W2SUM-P(N+NR+NB,1)
62425 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
62428 C...Find longitudinal string directions (i.e. lightlike four-vectors).
62430 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
62431 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
62434 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
62435 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
62437 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
62438 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
62440 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
62441 & DP(1,2)**2-DP(1,3)**2))
62442 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
62443 & DP(2,2)**2-DP(2,3)**2))
62447 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
62448 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62449 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62450 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62452 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62454 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62455 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62459 C...Begin initialization: sum up energy, set starting position.
62463 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62467 ELSEIF(NTRY.GT.100) THEN
62468 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62469 IF(MSTU(21).GE.1) RETURN
62476 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
62481 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
62482 IF(NS.GT.NR) IRANK(JT)=1
62484 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
62485 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
62486 IN(3*JT+2)=IN(3*JT+1)+1
62487 IN(3*JT+3)=N+NR+4*NS+2*JT-1
62488 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
62495 C.. MOPS variables and switches
62501 C...Initialize flavour and pT variables for open string.
62505 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
62509 KFL(JT)=K(IE(JT),2)
62510 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
62511 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
62513 PMQ(JT)=PYMASS(KFL(JT))
62517 C...Closed string: random initial breakup flavour, pT and vertex.
62519 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62521 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
62522 C.. Closed string: first vertex diq attempt => enforced second
62524 IF(IABS(KFL(1)).GT.10)THEN
62529 IF(IBMO.EQ.1) MSTU(121)=-1
62531 CALL PYPTDI(KFL(1),PX(1),PY(1))
62534 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
62535 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
62536 ZR=PR3/(Z*P(N+NR+1,5)**2)
62537 IF(ZR.GE.1D0) GOTO 780
62540 PMQ(JT)=PYMASS(KFL(JT))
62541 GAM(JT)=PR3*(1D0-Z)/Z
62542 IN1=N+NR+3+4*(JT/2)*(NS-1)
62545 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
62548 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
62554 PM2QMO(JT)=PMQ(JT)**2
62555 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
62558 C...Find initial transverse directions (i.e. spacelike four-vectors).
62560 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
62569 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62570 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62571 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62572 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62573 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62574 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62575 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62576 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62577 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62579 DHCX1=DFOUR(3,1)/DHC12
62580 DHCX2=DFOUR(3,2)/DHC12
62581 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62582 DHCY1=DFOUR(4,1)/DHC12
62583 DHCY2=DFOUR(4,2)/DHC12
62584 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62585 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62587 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62589 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62594 P(IN3+2,J)=P(IN3,J)
62595 P(IN3+3,J)=P(IN3+1,J)
62600 C...Remove energy used up in junction string fragmentation.
62601 IF(MJU(1)+MJU(2).GT.0) THEN
62603 IF(NJS(JT).EQ.0) GOTO 860
62605 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
62609 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62610 WMIN=PARJST+PMQ(1)+PMQ(2)
62611 WREM2=FOUR(N+NRS,N+NRS)
62612 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
62614 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
62619 C...Produce new particle: side, origin.
62621 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62622 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62623 IF(MSTU(21).GE.1) RETURN
62625 C.. New side priority for popcorn systems
62626 IF(MSTU(121).LE.0)THEN
62628 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
62629 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
62633 IRANK(JT)=IRANK(JT)+1
62638 C...Generate flavour, hadron and pT.
62640 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
62641 IF(K(I,2).EQ.0) GOTO 710
62643 IF(MSTU(121).EQ.-1) GOTO 910
62644 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
62645 &IABS(KFL(3)).GT.10) THEN
62646 IF(PYR(0).GT.PARJ(19)) GOTO 880
62648 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62650 P(I,5)=PYMASS(K(I,2))
62651 CALL PYPTDI(KFL(JT),PX(3),PY(3))
62652 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
62654 C...Final hadrons for small invariant mass.
62656 PMQ(3)=PYMASS(KFL(3))
62658 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62659 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
62660 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
62661 &WMIN-0.5D0*PARJ(36)*PMQ(3)
62662 WREM2=FOUR(N+NRS,N+NRS)
62663 IF(WREM2.LT.0.10D0) GOTO 710
62664 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
62665 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
62667 C...Choose z, which gives Gamma. Shift z for heavy flavours.
62668 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
62669 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
62670 &MSTU(90).LT.8) THEN
62671 MSTU(90)=MSTU(90)+1
62672 MSTU(90+MSTU(90))=I
62673 PARU(90+MSTU(90))=Z
62677 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62678 &MOD(KFL2A/1000,10)).GE.4) THEN
62679 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62680 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
62681 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
62682 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62683 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
62685 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
62687 C.. MOPS baryon model modification
62688 XTMO3=(1D0-Z)*XTMO(JT)
62689 IF(IABS(KFL(3)).LE.10) NRVMO=0
62690 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
62694 IF(IABS(KFL(JT)).LE.10)THEN
62695 XBMO=MIN(XTMO3,1D0-(2D-10))
62698 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
62699 GTSTMO=1D0-PARF(192)**PGMO
62701 IF(IRANK(JT).EQ.1) THEN
62706 IF(XBMO.LT.1D0-(1D-10))THEN
62707 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
62708 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
62711 IF(MSTJ(12).GE.5)THEN
62712 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
62713 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
62714 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
62719 C.. MOPS Accepting popcorn system hadron.
62720 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
62721 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
62723 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
62725 & '(PYSTRF:) no more memory left in PYJETS')
62726 IF(MSTU(21).GE.1) RETURN
62738 DO 890 LINE=1,I-N-NR
62739 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
62740 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
62747 C..Reject popcorn system, flag=-1 if enforcing new one
62749 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
62754 C..Lift restoring string outside MOPS block
62755 910 IF(MSTU(121).LT.0) THEN
62756 IF(MSTU(121).EQ.-2) MSTU(121)=0
62759 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
62770 DO 920 LINE=1,I-N-NR
62771 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
62772 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
62780 C.. MOPS end of modification
62786 C...Stepping within or from 'low' string region easy.
62787 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62788 &P(IN(1),5)**2.GE.PR(JT)) THEN
62789 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
62790 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
62792 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
62795 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62796 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62799 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62800 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62801 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62807 C...Find new transverse directions (i.e. spacelike string vectors).
62808 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
62809 &IN(1).GT.IN(2)) GOTO 710
62810 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
62817 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62818 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62820 IF(DHC12.LE.1D-2) THEN
62821 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62827 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62828 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62829 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62830 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62831 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62832 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62833 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62834 DHCX1=DFOUR(3,1)/DHC12
62835 DHCX2=DFOUR(3,2)/DHC12
62836 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62837 DHCY1=DFOUR(4,1)/DHC12
62838 DHCY2=DFOUR(4,2)/DHC12
62839 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62840 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62842 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62844 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62847 C...Express pT with respect to new axes, if sensible.
62848 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
62849 & FOUR(IN(3*JT+3)+1,IN(3)))
62850 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
62851 & FOUR(IN(3*JT+3)+1,IN(3)+1))
62852 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62858 C...Sum up known four-momentum. Gives coefficients for m2 expression.
62861 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
62862 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
62863 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
62864 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62866 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
62867 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62871 DHM(2)=2D0*FOUR(I,IN(1))
62872 DHM(3)=2D0*FOUR(I,IN(2))
62873 DHM(4)=2D0*FOUR(IN(1),IN(2))
62875 C...Find coefficients for Gamma expression.
62876 DO 1030 IN2=IN(1)+1,IN(2),4
62877 DO 1020 IN1=IN(1),IN2-1,4
62878 DHC=2D0*FOUR(IN1,IN2)
62879 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
62880 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
62881 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
62882 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62886 C...Solve (m2, Gamma) equation system for energies taken.
62887 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
62888 IF(ABS(DHS1).LT.1D-4) GOTO 710
62889 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
62890 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
62891 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
62892 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62893 &ABS(DHS1)-DHS2/DHS1)
62894 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
62895 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
62896 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
62898 C...Step to new region if necessary.
62899 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
62900 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62903 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62904 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62905 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62910 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
62911 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62917 C...Four-momentum of particle. Remaining quantities. Loop back.
62919 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
62920 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
62922 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
62923 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
62925 IF(P(I,4).LT.P(I,5)) GOTO 710
62931 IF(IN(3).NE.IN(3*JT+3)) THEN
62933 P(IN(3*JT+3),J)=P(IN(3),J)
62934 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
62939 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62940 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
62942 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62946 C...Final hadron: side, flavour, hadron, mass.
62952 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
62953 IF(K(I,2).EQ.0) GOTO 710
62954 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
62956 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62958 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62960 P(I,5)=PYMASS(K(I,2))
62961 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62963 C...Final two hadrons: find common setup of four-vectors.
62965 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
62966 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
62967 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
62968 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
62969 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
62970 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
62971 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
62972 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
62973 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
62974 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
62977 C...Solve kinematics for final two hadrons, if possible.
62978 WREM2=2D0*DHR1*DHR2*DHC12
62979 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
62980 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
62981 IF(FD.GE.1D0) GOTO 710
62982 FA=WREM2+PR(JT)-PR(JR)
62983 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
62985 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
62986 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
62987 FB=SIGN(FB,JS*(PYR(0)-PREV))
62990 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62991 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
62992 &4D0*WREM2*PR(JT))),DBLE(JS))
62994 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
62995 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
62996 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
62997 P(I,J)=P(N+NRS,J)-P(I-1,J)
62999 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
63000 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
63001 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
63002 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
63004 IF(NTRYFN.LT.100) GOTO 140
63005 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
63008 C...Mark jets as fragmented and give daughter pointers.
63010 DO 1100 I=NSAV+1,NSAV+NP
63013 IF(MSTU(16).NE.2) THEN
63022 C...Document string system. Move up particles.
63033 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63037 K(I,J)=K(I+NRS-1,J)
63038 P(I,J)=P(I+NRS-1,J)
63043 DO 1140 IZ=MSTU90+1,MSTU91
63044 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
63045 PARU9T(IZ)=PARU(90+IZ)
63049 C...Order particles in rank along the chain. Update mother pointer.
63052 K(I-NSAV+N,J)=K(I,J)
63053 P(I-NSAV+N,J)=P(I,J)
63057 DO 1190 I=N+1,2*N-NSAV
63058 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
63064 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63065 DO 1180 IZ=MSTU90+1,MSTU91
63066 IF(MSTU9T(IZ).EQ.I) THEN
63067 MSTU(90)=MSTU(90)+1
63068 MSTU(90+MSTU(90))=I1
63069 PARU(90+MSTU(90))=PARU9T(IZ)
63073 DO 1220 I=2*N-NSAV,N+1,-1
63074 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
63080 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63081 DO 1210 IZ=MSTU90+1,MSTU91
63082 IF(MSTU9T(IZ).EQ.I) THEN
63083 MSTU(90)=MSTU(90)+1
63084 MSTU(90+MSTU(90))=I1
63085 PARU(90+MSTU(90))=PARU9T(IZ)
63090 C...Boost back particle system. Set production vertices.
63093 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
63097 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
63098 IF(P(I,3).GT.0D0) THEN
63099 HHPEZ=(P(I,4)+P(I,3))*HHBZ
63100 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
63101 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63103 HHPEZ=(P(I,4)-P(I,3))/HHBZ
63104 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
63105 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63118 C*********************************************************************
63121 C...From three given input vectors in PJU the boost VJU from
63122 C...the "lab frame" to the junction rest frame is constructed.
63124 SUBROUTINE PYJURF(PJU,VJU)
63126 C...Double precision and integer declarations.
63127 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63128 IMPLICIT INTEGER(I-N)
63130 C...Input, output and local arrays.
63131 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
63132 DATA TWOPI/6.283186D0/
63134 C...Calculate masses and other invariants.
63136 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63138 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
63139 PSUM(5)=SQRT(PSUM2)
63142 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
63143 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
63147 C...Pick I to be most massive parton and J to be the one closest to I.
63150 IF(A(2,2).GT.A(1,1)) I=2
63151 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
63155 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
63166 C...Trivial find new parton energies if all three partons are massless.
63167 IF(PMI2.LT.1D-4) THEN
63168 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
63169 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
63170 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
63172 C...Else find momentum range for parton I and values at extremes.
63178 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
63179 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
63180 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
63181 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
63182 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
63183 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
63184 HI=PEIMAX**2-0.25D0*PAIMAX**2
63185 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
63186 & 0.5D0*PAIMAX*AIJ)/HI
63187 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
63188 & 0.5D0*PAIMAX*AIK)/HI
63189 PEJMAX=SQRT(PAJMAX**2+PMJ2)
63190 PEKMAX=SQRT(PAKMAX**2+PMK2)
63191 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
63193 C...If unexpected values at upper endpoint then pick another parton.
63194 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
63196 IF(A(I1,I1).GE.1D-4) THEN
63202 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
63208 C..Start binary + linear search to find solution inside range.
63212 PAI=0.5D0*(PAIMIN+PAIMAX)
63215 C...Derive momentum of other two partons and distance to root.
63216 PEI=SQRT(PAI**2+PMI2)
63217 HI=PEI**2-0.25D0*PAI**2
63218 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
63219 PEJ=SQRT(PAJ**2+PMJ2)
63220 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
63221 PEK=SQRT(PAK**2+PMK2)
63222 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
63224 C...Pick next I momentum to explore, hopefully closer to root.
63225 IF(FNOW.GT.0D0) THEN
63234 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
63236 PAI=0.5D0*(PAIMIN+PAIMAX)
63238 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
63239 & ABS(FNOW).GT.1D-12*PSUM2) THEN
63240 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
63245 C...Now know energies in junction rest frame.
63250 C...Boost (copy of) partons to their rest frame.
63251 VXCM=-PSUM(1)/PSUM(5)
63252 VYCM=-PSUM(2)/PSUM(5)
63253 VZCM=-PSUM(3)/PSUM(5)
63254 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
63256 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
63257 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
63258 PCM(I,1)=PJU(I,1)+FAC2*VXCM
63259 PCM(I,2)=PJU(I,2)+FAC2*VYCM
63260 PCM(I,3)=PJU(I,3)+FAC2*VZCM
63261 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
63262 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63265 C...Construct difference vectors and boost to junction rest frame.
63267 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
63268 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
63270 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
63271 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
63272 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
63273 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
63274 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
63275 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
63276 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
63277 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
63278 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
63279 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
63280 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
63282 C...Add two boosts, giving final result.
63283 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
63284 VJU(1)=VXJU+FCM*VXCM
63285 VJU(2)=VYJU+FCM*VYCM
63286 VJU(3)=VZJU+FCM*VZCM
63287 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
63290 C...In case of error in reconstruction: revert to CM frame of system.
63291 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63292 &(PCM(1,5)*PCM(2,5))
63293 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63294 &(PCM(1,5)*PCM(3,5))
63295 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63296 &(PCM(2,5)*PCM(3,5))
63297 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63298 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63300 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
63301 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
63302 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
63303 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
63304 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
63305 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
63306 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63308 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63309 &(PCM(1,5)*PCM(2,5))
63310 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63311 &(PCM(1,5)*PCM(3,5))
63312 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63313 &(PCM(2,5)*PCM(3,5))
63314 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63315 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63316 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
63326 C*********************************************************************
63329 C...Handles the fragmentation of a jet system (or a single
63330 C...jet) according to independent fragmentation models.
63332 SUBROUTINE PYINDF(IP)
63334 C...Double precision and integer declarations.
63335 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63336 IMPLICIT INTEGER(I-N)
63337 INTEGER PYK,PYCHGE,PYCOMP
63339 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63340 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63341 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63342 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
63344 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
63345 &KFLO(2),PXO(2),PYO(2),WO(2)
63347 C.. MOPS error message
63348 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
63349 &' are not treated as expected in independent fragmentation')
63351 C...Reset counters. Identify parton system and take copy. Check flavour.
63361 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
63362 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
63363 IF(MSTU(21).GE.1) RETURN
63365 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
63367 IF(KC.EQ.0) GOTO 110
63368 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
63369 IF(KQ.EQ.0) GOTO 110
63371 IF(KQ.NE.2) KQSUM=KQSUM+KQ
63373 K(NSAV+NJET,J)=K(I,J)
63374 P(NSAV+NJET,J)=P(I,J)
63375 DPS(J)=DPS(J)+P(I,J)
63378 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
63379 &K(I+1,1).EQ.2)) GOTO 110
63380 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
63381 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
63382 IF(MSTU(21).GE.1) RETURN
63385 C...Boost copied system to CM frame. Find CM energy and sum flavours.
63388 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
63389 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
63395 DO 140 I=NSAV+1,NSAV+NJET
63399 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
63400 ELSEIF(KFA.GT.1000) THEN
63401 KFLA=MOD(KFA/1000,10)
63402 KFLB=MOD(KFA/100,10)
63403 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
63404 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
63408 C...Loop over attempts made. Reset counters.
63411 IF(NTRY.GT.200) THEN
63412 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
63413 IF(MSTU(21).GE.1) RETURN
63423 C...Loop over jets to be fragmented.
63424 DO 230 IP1=NSAV+1,NSAV+NJET
63429 C...Initial flavour and momentum values. Jet along +z axis.
63430 KFLH=IABS(K(IP1,2))
63431 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
63433 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
63435 C...Initial values for quark or diquark jet.
63436 170 IF(IABS(K(IP1,2)).NE.21) THEN
63439 CALL PYPTDI(0,PXO(1),PYO(1))
63442 C...Initial values for gluon treated like random quark jet.
63443 ELSEIF(MSTJ(2).LE.2) THEN
63445 IF(MSTJ(2).EQ.2) MSTJ(91)=1
63446 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63447 CALL PYPTDI(0,PXO(1),PYO(1))
63450 C...Initial values for gluon treated like quark-antiquark jet pair,
63451 C...sharing energy according to Altarelli-Parisi splitting function.
63454 IF(MSTJ(2).EQ.4) MSTJ(91)=1
63455 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63457 CALL PYPTDI(0,PXO(1),PYO(1))
63460 WO(1)=WF*PYR(0)**(1D0/3D0)
63464 C...Initial values for rank, flavour, pT and W+.
63474 C...New hadron. Generate flavour and hadron species.
63476 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
63477 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
63478 IF(MSTU(21).GE.1) RETURN
63485 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
63486 IF(K(I,2).EQ.0) GOTO 180
63487 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
63488 IF(PYR(0).GT.PARJ(19)) GOTO 200
63491 C...Find hadron mass. Generate four-momentum.
63492 P(I,5)=PYMASS(K(I,2))
63493 CALL PYPTDI(KFL1,PX2,PY2)
63496 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
63497 CALL PYZDIS(KFL1,KFL2,PR,Z)
63499 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
63501 MSTU(90)=MSTU(90)+1
63502 MSTU(90+MSTU(90))=I
63503 PARU(90+MSTU(90))=Z
63505 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
63506 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
63507 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
63508 & P(I,3).LE.0.001D0) THEN
63509 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
63515 C...Remaining flavour and momentum.
63524 C...Check if pL acceptable. Go back for new hadron if enough energy.
63525 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
63527 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
63529 IF(W.GT.PARJ(31)) GOTO 190
63532 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
63533 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
63535 C...Rotate jet to new direction.
63536 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
63537 PHI=PYANGL(P(IP1,1),P(IP1,2))
63539 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
63540 K(K(IP1,3),4)=NSAV1+1
63543 C...End of jet generation loop. Skip conservation in some cases.
63545 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
63546 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
63548 C...Subtract off produced hadron flavours, finished if zero.
63549 DO 240 I=NSAV+NJET+1,N
63551 KFLA=MOD(KFA/1000,10)
63552 KFLB=MOD(KFA/100,10)
63553 KFLC=MOD(KFA/10,10)
63555 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
63556 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
63558 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
63559 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
63560 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
63563 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63564 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63565 IF(NREQ.EQ.0) GOTO 320
63567 C...Take away flavour of low-momentum particles until enough freedom.
63571 DO 260 I=NSAV+NJET+1,N
63572 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
63573 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
63574 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
63576 IF(IREM.EQ.0) GOTO 150
63578 KFA=IABS(K(IREM,2))
63579 KFLA=MOD(KFA/1000,10)
63580 KFLB=MOD(KFA/100,10)
63581 KFLC=MOD(KFA/10,10)
63582 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
63583 IF(K(IREM,1).EQ.8) GOTO 250
63585 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
63586 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
63587 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
63589 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
63590 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
63591 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
63594 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63595 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63596 IF(NREQ.GT.NREM) GOTO 250
63597 DO 270 I=NSAV+NJET+1,N
63598 IF(K(I,1).EQ.8) K(I,1)=1
63601 C...Find combination of existing and new flavours for hadron.
63603 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
63604 IF(NREQ.LT.NREM) NFET=1
63605 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
63607 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
63608 KFLF(J)=ISIGN(1,NFL(1))
63609 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
63610 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
63612 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
63614 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
63615 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
63616 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
63617 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
63618 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
63619 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
63620 IF(NFET.LE.2) KFLF(3)=0
63621 IF(KFLF(3).NE.0) THEN
63622 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
63623 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
63624 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
63625 & KFLFC=KFLFC+ISIGN(2,KFLFC)
63629 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
63630 IF(KF.EQ.0) GOTO 280
63631 DO 300 J=1,MAX(2,NFET)
63632 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
63635 C...Store hadron at random among free positions.
63636 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
63637 DO 310 I=NSAV+NJET+1,N
63638 IF(K(I,1).EQ.7) NPOS=NPOS-1
63639 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
63642 P(I,5)=PYMASS(K(I,2))
63643 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63646 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63647 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63648 IF(NREM.GT.0) GOTO 280
63650 C...Compensate for missing momentum in global scheme (3 options).
63651 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
63654 DO 330 I=NSAV+NJET+1,N
63655 PSI(J)=PSI(J)+P(I,J)
63658 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
63660 DO 350 I=NSAV+NJET+1,N
63661 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
63662 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63663 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63664 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
63666 DO 370 I=NSAV+NJET+1,N
63667 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
63668 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63669 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63670 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
63672 P(I,J)=P(I,J)-PSI(J)*PW/PWS
63674 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63677 C...Compensate for missing momentum withing each jet separately.
63678 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
63679 DO 390 I=N+1,N+NJET
63685 DO 410 I=NSAV+NJET+1,N
63688 K(IR2,1)=K(IR2,1)+1
63689 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63690 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63692 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
63694 P(IR2,4)=P(IR2,4)+P(I,4)
63695 P(IR2,5)=P(IR2,5)+PLS
63698 DO 420 I=N+1,N+NJET
63699 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
63701 DO 440 I=NSAV+NJET+1,N
63704 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63705 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63707 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
63710 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63714 C...Scale momenta for energy conservation.
63715 IF(MOD(MSTJ(3),5).NE.0) THEN
63719 DO 450 I=NSAV+NJET+1,N
63722 PQS=PQS+P(I,5)**2/P(I,4)
63724 IF(PMS.GE.PECM) GOTO 150
63727 PFAC=(PECM-PQS)/(PES-PQS)
63730 DO 480 I=NSAV+NJET+1,N
63734 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63736 PQS=PQS+P(I,5)**2/P(I,4)
63738 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
63741 C...Origin of produced particles and parton daughter pointers.
63742 490 DO 500 I=NSAV+NJET+1,N
63743 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
63744 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
63746 DO 510 I=NSAV+1,NSAV+NJET
63749 IF(MSTU(16).NE.2) THEN
63753 K(I1,4)=K(I1,4)-NJET+1
63754 K(I1,5)=K(I1,5)-NJET+1
63755 IF(K(I1,5).LT.K(I1,4)) THEN
63762 C...Document independent fragmentation system. Remove copy of jets.
63773 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63775 DO 540 I=NSAV+NJET,N
63777 K(I-NJET+1,J)=K(I,J)
63778 P(I-NJET+1,J)=P(I,J)
63779 V(I-NJET+1,J)=V(I,J)
63783 DO 550 IZ=MSTU90+1,MSTU(90)
63784 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
63787 C...Boost back particle system. Set production vertices.
63788 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
63789 &DPS(2)/DPS(4),DPS(3)/DPS(4))
63799 C*********************************************************************
63802 C...Handles the decay of unstable particles.
63804 SUBROUTINE PYDECY(IP)
63806 C...Double precision and integer declarations.
63807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63808 IMPLICIT INTEGER(I-N)
63809 INTEGER PYK,PYCHGE,PYCOMP
63811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63813 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63814 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
63815 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
63817 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
63818 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
63820 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
63822 C...Functions: momentum in two-particle decays and four-product.
63823 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
63824 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)
63826 C...Initial values.
63830 KFS=ISIGN(1,K(IP,2))
63834 C...Choose lifetime and determine decay vertex.
63835 IF(K(IP,1).EQ.5) THEN
63837 ELSEIF(K(IP,1).NE.4) THEN
63838 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
63841 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
63844 C...Determine whether decay allowed or not.
63846 IF(MSTJ(22).EQ.2) THEN
63847 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
63848 ELSEIF(MSTJ(22).EQ.3) THEN
63849 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
63850 ELSEIF(MSTJ(22).EQ.4) THEN
63851 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
63852 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
63854 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
63859 C...Interface to external tau decay library (for tau polarization).
63860 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
63862 C...Starting values for pointers and momenta.
63866 PCMTAU(J)=P(ITAU,J)
63869 C...Iterate to find position and code of mother of tau.
63871 120 IMTAU=K(IMTAU,3)
63873 IF(IMTAU.EQ.0) THEN
63874 C...If no known origin then impossible to do anything further.
63878 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
63879 C...If tau -> tau + gamma then add gamma energy and loop.
63880 IF(K(K(IMTAU,4),2).EQ.22) THEN
63882 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
63884 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
63886 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
63891 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
63892 C...If coming from weak decay of hadron then W is not stored in record,
63893 C...but can be reconstructed by adding neutrino momentum.
63894 KFORIG=-ISIGN(24,K(ITAU,2))
63896 DO 160 II=K(IMTAU,4),K(IMTAU,5)
63897 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
63899 PCMTAU(J)=PCMTAU(J)+P(II,J)
63905 C...If coming from resonance decay then find latest copy of this
63906 C...resonance (may not completely agree).
63909 DO 170 II=IMTAU+1,IP-1
63910 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
63911 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
63914 PCMTAU(J)=P(IORIG,J)
63918 C...Boost tau to rest frame of production process (where known)
63919 C...and rotate it to sit along +z axis.
63921 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
63923 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
63924 & -DBETAU(2),-DBETAU(3))
63925 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
63926 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
63927 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
63928 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
63930 C...Call tau decay routine (if meaningful) and fill extra info.
63931 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63932 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
63933 DO 200 II=NSAV+1,NSAV+NDECAY
63942 C...Boost back decay tau and decay products.
63946 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63947 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
63948 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
63949 & DBETAU(2),DBETAU(3))
63951 C...Skip past ordinary tau decay treatment.
63959 C...B-Bbar mixing: flip sign of meson appropriately.
63961 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
63963 IF(KFA.EQ.531) XBBMIX=PARJ(77)
63964 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
63965 IF(MMIX.EQ.1) KFS=-KFS
63968 C...Check existence of decay channels. Particle/antiparticle rules.
63970 IF(MDCY(KC,2).GT.0) THEN
63971 MDMDCY=MDME(MDCY(KC,2),2)
63972 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
63974 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
63975 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
63978 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
63979 IF(KCHG(KC,3).EQ.0) THEN
63982 IF(PYR(0).GT.0.5D0) KFS=-KFS
63983 ELSEIF(KFS.GT.0) THEN
63991 C...Sum branching ratios of allowed decay channels.
63994 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
63995 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
63996 & KFSN*MDME(IDL,1).NE.3) GOTO 230
63997 IF(MDME(IDL,2).GT.100) GOTO 230
63999 BRSU=BRSU+BRAT(IDL)
64002 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
64006 C...Select decay channel among allowed ones.
64007 240 RBR=BRSU*PYR(0)
64010 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64011 &KFSN*MDME(IDL,1).NE.3) THEN
64012 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64013 ELSEIF(MDME(IDL,2).GT.100) THEN
64014 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64018 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
64021 C...Start readout of decay channel: matrix element, reset counters.
64024 IF(MOD(NTRY,200).EQ.0) THEN
64025 WRITE(CIDC,'(I4)') IDC
64026 C...Do not print warning for some well-known special cases.
64027 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
64028 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
64032 IF(NTRY.GT.1000) THEN
64033 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64034 IF(MSTU(21).GE.1) RETURN
64040 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
64043 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
64045 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
64051 IF(KFA.GT.80) MHADDY=1
64052 C.. Random flavour and popcorn system memory.
64058 C...Read out decay products. Convert to standard flavour code.
64060 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
64062 IF(JT.LE.5) KP=KFDP(IDC,JT)
64063 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
64064 IF(KP.EQ.0) GOTO 280
64067 IF(KPA.GT.80) MHADDY=1
64068 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
64070 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
64072 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
64073 KFP=-KFS*MOD(KFA/10,10)
64074 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
64075 KFP=KFS*(100*MOD(KFA/10,100)+3)
64076 ELSEIF(KPA.EQ.81) THEN
64077 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
64078 ELSEIF(KP.EQ.82) THEN
64079 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
64080 IF(KFP.EQ.0) GOTO 260
64084 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
64085 ELSEIF(KP.EQ.-82) THEN
64088 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
64090 C...Add decay product to event record or to quark flavour list.
64093 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
64096 C...set rndmflav popcorn system pointer
64097 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
64099 PSQ=PSQ+PYMASS(KFLO(NQ))
64100 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
64101 & MOD(NQ,2).EQ.1) THEN
64106 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
64107 IF(K(I,2).EQ.0) GOTO 260
64109 P(I,5)=PYMASS(K(I,2))
64114 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
64115 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
64117 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
64118 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
64128 C...Check masses for resonance decays.
64129 IF(MHADDY.EQ.0) THEN
64130 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
64133 C...Choose decay multiplicity in phase space model.
64134 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
64136 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
64137 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
64139 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
64140 IF(IRNDMO.EQ.0) THEN
64143 ELSEIF(IRNDMO.EQ.1) THEN
64148 IF(NTRY.GT.1000) THEN
64149 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64150 IF(MSTU(21).GE.1) RETURN
64152 IF(MMAT.LE.20) THEN
64153 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
64154 & SIN(PARU(2)*PYR(0))
64155 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
64156 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
64157 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
64158 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
64159 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
64163 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
64165 IF(MSTU(121).GT.MSTU(125)) GOTO 300
64167 C...Form hadrons from flavour content.
64171 IF(ND.EQ.NP+NQ/2) GOTO 330
64172 DO 320 I=N+NP+1,N+ND-NQ/2
64173 C.. Stick to started popcorn system, else pick side at random
64175 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
64176 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
64177 IF(K(I,2).EQ.0) GOTO 300
64178 MSTU(125)=MSTU(125)-1
64180 IF(MSTU(121).GT.0) JTMO=JT
64186 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
64187 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
64188 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
64191 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
64192 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
64193 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
64194 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
64196 C...Check that sum of decay product masses not too large.
64198 DO 340 I=N+NP+1,N+ND
64203 P(I,5)=PYMASS(K(I,2))
64206 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
64208 C...Rescale energy to subtract off spectator quark mass.
64209 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
64210 & .AND.NP.GE.3) THEN
64212 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
64214 P(N+NP,J)=PQT*PV(1,J)
64215 PV(1,J)=(1D0-PQT)*PV(1,J)
64217 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64221 C...Fully specified final state: check mass broadening effects.
64223 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
64227 C...Determine position of grandmother, number of sisters.
64233 IF(IM.LT.0.OR.IM.GE.IP) IM=0
64234 IF(IM.NE.0) KFAM=IABS(K(IM,2))
64236 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
64237 IF(K(IL,3).EQ.IM) NM=NM+1
64238 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
64240 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
64241 & MOD(KFAM/1000,10).NE.0) NM=0
64243 KFAS=IABS(K(ISIS,2))
64244 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
64245 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
64250 C...Kinematics of one-particle decays.
64258 C...Calculate maximum weight ND-particle decay.
64261 WTMAX=1D0/WTCOR(ND-2)
64262 PMAX=PV(1,5)-PS+P(N+ND,5)
64264 DO 380 IL=ND-1,1,-1
64265 PMAX=PMAX+P(N+IL,5)
64266 PMIN=PMIN+P(N+IL+1,5)
64267 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
64271 C...Find virtual gamma mass in Dalitz decay.
64272 390 IF(ND.EQ.2) THEN
64273 ELSEIF(MMAT.EQ.2) THEN
64274 PMES=4D0*PMAS(11,1)**2
64275 PMRHO2=PMAS(131,1)**2
64276 PGRHO2=PMAS(131,2)**2
64277 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
64278 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
64279 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
64280 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
64281 IF(WT.LT.PYR(0)) GOTO 400
64282 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
64284 C...M-generator gives weight. If rejected, try again.
64289 DO 420 IL2=IL1-1,1,-1
64290 IF(RSAV.LE.RORD(IL2)) GOTO 430
64291 RORD(IL2+1)=RORD(IL2)
64293 430 RORD(IL2+1)=RSAV
64297 DO 450 IL=ND-1,1,-1
64298 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
64300 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64302 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
64305 C...Perform two-particle decays in respective CM frame.
64306 460 DO 480 IL=1,ND-1
64307 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64308 UE(3)=2D0*PYR(0)-1D0
64310 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
64311 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
64314 PV(IL+1,J)=-PA*UE(J)
64316 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
64317 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
64320 C...Lorentz transform decay products to lab frame.
64324 DO 530 IL=ND-1,1,-1
64326 BE(J)=PV(IL,J)/PV(IL,4)
64328 GA=PV(IL,4)/PV(IL,5)
64330 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64332 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64334 P(I,4)=GA*(P(I,4)+BEP)
64338 C...Check that no infinite loop in matrix element weight.
64340 IF(NTRY.GT.800) GOTO 560
64342 C...Matrix elements for omega and phi decays.
64344 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
64345 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
64346 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
64347 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
64349 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
64350 ELSEIF(MMAT.EQ.2) THEN
64351 FOUR12=FOUR(N+1,N+2)
64352 FOUR13=FOUR(N+1,N+3)
64353 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
64354 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
64355 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
64357 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
64358 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
64359 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
64360 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
64362 FOUR12=FOUR(IP,N+1)
64363 FOUR02=FOUR(IM,N+1)
64367 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
64368 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
64369 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
64370 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
64371 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
64372 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
64374 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
64375 ELSEIF(MMAT.EQ.4) THEN
64376 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64377 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
64378 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
64379 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
64380 & ((1D0-HX3)/(HX1*HX2))**2
64381 IF(WT.LT.2D0*PYR(0)) GOTO 390
64382 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
64385 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
64386 ELSEIF(MMAT.EQ.41) THEN
64387 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64388 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
64389 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
64390 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
64392 C...Matrix elements for weak decays (only semileptonic for c and b)
64393 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64394 & .AND.ND.EQ.3) THEN
64395 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
64396 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
64397 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64398 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
64402 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
64405 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
64406 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
64407 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64410 C...Scale back energy and reattach spectator.
64411 560 IF(MREM.EQ.1) THEN
64413 PV(1,J)=PV(1,J)/(1D0-PQT)
64419 C...Low invariant mass for system with spectator quark gives particle,
64420 C...not two jets. Readjust momenta accordingly.
64421 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
64423 PM2=PYMASS(K(N+2,2))
64425 PM3=PYMASS(K(N+3,2))
64426 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
64427 & (PARJ(32)+PM2+PM3)**2) GOTO 630
64430 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
64431 IF(K(N+2,2).EQ.0) GOTO 260
64432 P(N+2,5)=PYMASS(K(N+2,2))
64433 PS=P(N+1,5)+P(N+2,5)
64438 ELSEIF(MMAT.EQ.44) THEN
64440 PM3=PYMASS(K(N+3,2))
64442 PM4=PYMASS(K(N+4,2))
64443 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
64444 & (PARJ(32)+PM3+PM4)**2) GOTO 600
64447 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
64448 IF(K(N+3,2).EQ.0) GOTO 260
64449 P(N+3,5)=PYMASS(K(N+3,2))
64451 P(N+3,J)=P(N+3,J)+P(N+4,J)
64453 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)
64454 HA=P(N+1,4)**2-P(N+2,4)**2
64455 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
64456 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
64457 & (P(N+1,3)-P(N+2,3))**2
64458 HD=(PV(1,4)-P(N+3,4))**2
64459 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
64462 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
64464 PCOR=HH*(P(N+1,J)-P(N+2,J))
64465 P(N+1,J)=P(N+1,J)+PCOR
64466 P(N+2,J)=P(N+2,J)-PCOR
64468 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)
64469 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)
64473 C...Check invariant mass of W jets. May give one particle or start over.
64474 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64475 &.AND.IABS(K(N+1,2)).LT.10) THEN
64476 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
64478 PM1=PYMASS(K(N+1,2))
64480 PM2=PYMASS(K(N+2,2))
64481 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
64482 KFLDUM=INT(1.5D0+PYR(0))
64483 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
64484 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
64485 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
64486 PSM=PYMASS(KF1)+PYMASS(KF2)
64487 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
64488 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
64489 IF(MMAT.EQ.48) GOTO 390
64490 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
64493 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
64494 IF(K(N+1,2).EQ.0) GOTO 260
64495 P(N+1,5)=PYMASS(K(N+1,2))
64498 PS=P(N+1,5)+P(N+2,5)
64499 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64506 C...Phase space decay of partons from W decay.
64507 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
64513 PV(1,J)=P(N+1,J)+P(N+2,J)
64522 PSQ=PYMASS(KFLO(1))
64524 PSQ=PSQ+PYMASS(KFLO(2))
64529 C...Boost back for rapidly moving particle.
64533 BE(J)=P(IP,J)/P(IP,4)
64537 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64539 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64541 P(I,4)=GA*(P(I,4)+BEP)
64545 C...Fill in position of decay vertex.
64553 C...Set up for parton shower evolution from jets.
64554 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
64558 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64559 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64560 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64561 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64562 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64563 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64565 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
64568 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64569 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
64570 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
64571 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64573 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64574 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
64577 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64578 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
64579 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
64580 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64582 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64583 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
64585 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
64590 KCP=PYCOMP(K(NSAV+1,2))
64591 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
64593 IF(KQP.LT.0) JCON=5
64594 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
64595 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
64596 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
64597 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
64599 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
64602 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
64603 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64604 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64605 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
64609 C...Mark decayed particle; special option for B-Bbar mixing.
64610 IF(K(IP,1).EQ.5) K(IP,1)=15
64611 IF(K(IP,1).LE.10) K(IP,1)=11
64612 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
64620 C*********************************************************************
64623 C...Handles flavour production in the decay of unstable particles
64624 C...and small string clusters.
64626 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
64628 C...Double precision and integer declarations.
64629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64630 IMPLICIT INTEGER(I-N)
64631 INTEGER PYK,PYCHGE,PYCOMP
64633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64634 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64635 SAVE /PYDAT1/,/PYDAT2/
64638 C.. Call PYKFDI directly if no popcorn option is on
64639 IF(MSTJ(12).LT.2) THEN
64640 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64647 IF(KFL1.EQ.0) RETURN
64652 NMAX=MIN(MSTU(125),10)
64654 C.. Identify rank 0 cluster qq
64656 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
64659 C.. Join jets: Fails if store not empty
64660 IF(MSTU(121).GT.0) THEN
64664 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64665 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
64666 C.. Pick popcorn meson from store, return same qq, decrease store
64667 KF=MSTU(NSTO+MSTU(121))
64669 MSTU(121)=MSTU(121)-1
64671 C.. Generate new flavour. Then done if no diquark is generated
64672 100 CALL PYKFDI(KFL1,0,KFL3,KF)
64673 IF(MSTU(121).EQ.-1) GOTO 100
64675 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
64677 C.. Simple case if no dynamical popcorn suppressions are considered
64678 IF(MSTJ(12).LT.4) THEN
64679 IF(MSTU(121).EQ.0) RETURN
64682 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64683 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
64684 IF(IABS(KFL3).LE.10)THEN
64691 C test output qq against fake Gamma, then return if no popcorn.
64694 CALL PYZDIS(1,2103,5D0,Z)
64696 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
64701 IF(MSTU(121).EQ.0) RETURN
64703 C..Set store size memory. Pick fake dynamical variables of qq.
64705 CALL PYPTDI(1,PX3,PY3)
64711 C.. Pick next popcorn meson, test with fake dynamical variables
64715 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64716 IF(MSTU(121).EQ.-1) GOTO 100
64717 CALL PYPTDI(KFL3,PX3,PY3)
64718 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
64719 CALL PYZDIS(KFPREV,KFL3,PM,Z)
64726 IF(MSTJ(12).GT.4)THEN
64727 POPMN=SQRT((1D0-X)*(G/X-GB))
64728 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64729 PTST=EXP((POPM-POPMN)*PARF(193))
64734 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
64737 IF(RTST.GT.PTST*GTST)THEN
64739 IF(RTST.GT.PTST) MSTU(121)=-1
64744 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
64745 IF(MSTU(121).GT.0) GOTO 110
64747 C.. Test accepted system size. If OK set global popcorn size variable.
64748 IF(NMES.GT.NMAX)THEN
64759 C********************************************************************
64762 C...Generates a new flavour pair and combines off a hadron
64764 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
64766 C...Double precision and integer declarations.
64767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64768 IMPLICIT INTEGER(I-N)
64769 INTEGER PYK,PYCHGE,PYCOMP
64771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64772 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64773 SAVE /PYDAT1/,/PYDAT2/
64777 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
64779 C...Default flavour values. Input consistency checks.
64784 IF(KF1A.EQ.0) RETURN
64786 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
64787 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
64788 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
64791 C...Check if tabulated flavour probabilities are to be used.
64792 IF(MSTJ(15).EQ.1) THEN
64793 IF(MSTJ(12).GE.5) CALL PYERRM(29,
64794 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
64795 & ' together with MSTJ(12)>=5 modification')
64797 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
64798 KFL1A=MOD(KF1A/1000,10)
64799 KFL1B=MOD(KF1A/100,10)
64801 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
64802 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
64803 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
64804 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
64808 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
64809 KFL2A=MOD(KF2A/1000,10)
64810 KFL2B=MOD(KF2A/100,10)
64812 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
64813 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
64814 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
64816 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
64819 C.. Recognize rank 0 diquark case
64821 KFDIQ=MAX(KF1A,KF2A)
64822 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
64824 C.. Join two flavours to meson or baryon. Test for popcorn.
64827 IF(KFDIQ.GT.10) THEN
64828 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
64829 & CALL PYNMES(KFDIQ)
64830 IF(MSTU(121).NE.0) THEN
64841 C.. Separate incoming flavours, curtain flavour consistency check
64847 KFL1A=MOD(KF1A/1000,10)
64848 KFL1B=MOD(KF1A/100,10)
64851 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
64852 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
64853 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
64855 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
64859 KFQOLD=KFL1A+KFL1B-KFQPOP
64862 C...Meson/baryon choice. Set number of mesons if starting a popcorn
64865 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
64866 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
64870 ELSEIF(KF1A.GT.10)THEN
64872 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
64873 IF(MSTU(121).GT.0) MBARY=-1
64876 C..x->H+q: Choose single vertex quark. Jump to form hadron.
64877 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
64878 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
64879 KFL3=ISIGN(KFQVER,-KFIN)
64883 C..x->H+qq: (IDW=proper PARF position for diquark weights)
64886 IF(MSTU(121).EQ.0) IDW=150
64888 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
64889 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
64890 C.. Shift to s-curtain parameters if needed
64891 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
64892 PARF(194)=PARF(138)*PARF(139)
64893 PARF(193)=PARJ(8)+PARJ(9)
64897 C.. x->H+qq: Get vertex quark
64898 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64900 MSTU(121)=MSTU(121)-1
64901 IF(IDW.EQ.170) THEN
64902 IF(MSTU(121).EQ.0)THEN
64903 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
64905 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
64908 IF(MSTU(121).EQ.0)THEN
64909 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
64911 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
64917 RMES=PYR(0)*PARF(194)
64919 RMES=RMES-PARF(IPOS+IMES)
64920 IF(IMES.EQ.30) THEN
64925 IF(RMES.GT.0D0) GOTO 120
64928 IF(KMUL.EQ.2) KFJ=10003
64929 IF(KMUL.EQ.3) KFJ=10001
64930 IF(KMUL.EQ.4) KFJ=20003
64931 IF(KMUL.EQ.5) KFJ=5
64933 KFQVER=MOD(IMES,5)+1
64934 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
64935 IF(KFQVER.GT.3)THEN
64940 IF(MBARY.EQ.-1) IDW=170
64942 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
64943 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
64944 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
64945 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
64947 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
64951 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
64953 IF(KFQPOP.NE.KFQVER)THEN
64955 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
64956 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
64957 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
64959 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
64961 KFL3=ISIGN(KFDIQ,KFIN)
64963 C..x->M+y: flavour for meson.
64964 130 IF(MBARY.LE.0)THEN
64965 KFLA=MAX(KFQOLD,KFQVER)
64966 KFLB=MIN(KFQOLD,KFQVER)
64968 IF(KFLA.NE.KFQOLD) KFS=-KFS
64969 C... Form meson, with spin and flavour mixing for diagonal states.
64970 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64971 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
64972 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
64975 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
64976 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
64977 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
64978 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
64979 IF(PYR(0).LT.PARJ(14)) KMUL=2
64980 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
64982 IF(RMUL.LT.PARJ(15)) KMUL=3
64983 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
64984 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
64987 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
64988 IF(KMUL.EQ.5) KFLS=5
64989 IF(KFLA.NE.KFLB)THEN
64990 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
64993 IMIX=2*KFLA+10*KMUL
64994 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
64995 & INT(RMIX+PARF(IMIX)))+KFLS
64996 IF(KFLA.GE.4) KF=110*KFLA+KFLS
64998 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
64999 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
65001 C..Optional extra suppression of eta and eta'.
65002 C..Allow shift to qq->B+q in old version (set IRANK to 0)
65003 IF(KF.EQ.221.OR.KF.EQ.331)THEN
65004 IF(PYR(0).GT.PARJ(25+KF/300))THEN
65005 IF(KF2A.GT.0) GOTO 130
65006 IF(MSTJ(12).LT.4) IRANK=0
65012 C.. x->B+y: Flavour for baryon
65015 IF(KF1A.LE.10) KFLA=KFQOLD
65016 KFLB=MOD(KFDIQ/1000,10)
65017 KFLC=MOD(KFDIQ/100,10)
65018 KFLDS=MOD(KFDIQ,10)
65019 KFLD=MAX(KFLA,KFLB,KFLC)
65020 KFLF=MIN(KFLA,KFLB,KFLC)
65021 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65023 C... SU(6) factors for formation of baryon.
65027 IF(KFLB.NE.KFLC)THEN
65030 IF(KFLB.GT.2) KDMAX=KDMAX+2
65032 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
65037 SU6MAX=PARF(140+KDMAX)
65040 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
65045 SU6OCT=PARF(60+KBARY)
65046 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
65047 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
65048 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
65050 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
65052 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
65054 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
65055 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
65057 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
65061 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
65064 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
65065 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
65067 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
65069 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
65070 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
65074 C...Use tabulated probabilities to select new flavour and hadron.
65075 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
65078 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
65081 ELSEIF(KTAB2.EQ.0) THEN
65090 DO 150 KT3=KT3L,KT3U
65091 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
65097 DO 170 KT3=KT3L,KT3U
65099 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
65100 IF(RFL.LE.0D0) GOTO 190
65105 C...Reconstruct flavour of produced quark/diquark.
65106 IF(KTAB3.LE.6) THEN
65109 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
65112 IF(KTAB3.GE.8) KFL3A=2
65113 IF(KTAB3.GE.11) KFL3A=3
65114 IF(KTAB3.GE.16) KFL3A=4
65115 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
65116 KFL3=1000*KFL3A+100*KFL3B+1
65117 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
65119 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
65122 C...Reconstruct meson code.
65123 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
65125 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65126 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
65128 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
65129 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65130 & 25*KTABS)) KF=330+2*KTABS+1
65131 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
65132 KFLA=MAX(KTAB1,KTAB3)
65133 KFLB=MIN(KTAB1,KTAB3)
65135 IF(KFLA.NE.KF1A) KFS=-KFS
65136 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65137 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
65139 IF(KFL1A.EQ.KFL3A) THEN
65140 KFLA=MAX(KFL1B,KFL3B)
65141 KFLB=MIN(KFL1B,KFL3B)
65142 IF(KFLA.NE.KFL1B) KFS=-KFS
65143 ELSEIF(KFL1A.EQ.KFL3B) THEN
65147 ELSEIF(KFL1B.EQ.KFL3A) THEN
65150 ELSEIF(KFL1B.EQ.KFL3B) THEN
65151 KFLA=MAX(KFL1A,KFL3A)
65152 KFLB=MIN(KFL1A,KFL3A)
65153 IF(KFLA.NE.KFL1A) KFS=-KFS
65155 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
65158 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65160 C...Reconstruct baryon code.
65162 IF(KTAB1.GE.7) THEN
65171 KFLD=MAX(KFLA,KFLB,KFLC)
65172 KFLF=MIN(KFLA,KFLB,KFLC)
65173 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65174 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
65175 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
65178 C...Check that constructed flavour code is an allowed one.
65179 IF(KFL2.NE.0) KFL3=0
65182 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
65190 C*********************************************************************
65193 C...Generates number of popcorn mesons and stores some relevant
65196 SUBROUTINE PYNMES(KFDIQ)
65198 C...Double precision and integer declarations.
65199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65200 IMPLICIT INTEGER(I-N)
65201 INTEGER PYK,PYCHGE,PYCOMP
65203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65204 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65205 SAVE /PYDAT1/,/PYDAT2/
65208 IF(MSTJ(12).LT.2) RETURN
65210 C..Old version: Get 1 or 0 popcorn mesons
65211 IF(MSTJ(12).LT.5)THEN
65213 IF(KFDIQ.NE.0) THEN
65215 KFA=MOD(KFDIQA/1000,10)
65216 KFB=MOD(KFDIQA/100,10)
65219 IF(KFA.EQ.3) POPWT=PARF(133)
65220 IF(KFB.EQ.3) POPWT=PARF(134)
65221 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
65223 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
65227 C..New version: Store popcorn- or rank 0 diquark parameters
65230 PARF(194)=PARF(139)
65231 IF(KFDIQ.NE.0) THEN
65234 PARF(194)=PARF(140)
65236 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
65237 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
65238 & '(PYNMES:) Neglecting too large popcorn possibility')
65242 C..New version: Get number of popcorn mesons
65245 110 MSTU(121)=MSTU(121)+1
65246 RTST=RTST/PARF(194)
65247 IF(RTST.LT.1D0) GOTO 110
65248 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
65249 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
65253 C***************************************************************
65256 C...Precalculates a set of diquark and popcorn weights.
65260 C...Double precision and integer declarations.
65261 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65262 IMPLICIT INTEGER(I-N)
65263 INTEGER PYK,PYCHGE,PYCOMP
65265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65267 SAVE /PYDAT1/,/PYDAT2/
65269 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
65273 C..Diquark indices for dimensional variables
65282 C.. *** SU(6) factors **
65283 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
65285 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
65286 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
65287 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
65290 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
65292 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
65293 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
65295 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
65296 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
65299 C..SU(6)max q q' s,c,b
65300 SU6MUD =MAX(SU6(1) , SU6(8) )
65301 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
65302 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
65303 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
65304 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
65305 SU6M(IUS0)=SU6M(ISU0)
65306 SU6M(ISS1)=SU6M(IUU1)
65307 SU6M(IUS1)=SU6M(ISU1)
65309 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
65311 PARF(142)=SU6M(IUD1)
65312 PARF(143)=SU6M(ISU0)
65313 PARF(144)=SU6M(ISU1)
65314 PARF(145)=SU6M(ISS1)
65316 C..diquark SU(6) survival =
65317 C..sum over quark (quark tunnel weight)*(SU(6)).
65318 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
65319 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
65320 DMB(IUS0)=DMB(ISU0)
65321 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
65322 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
65323 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
65324 DMB(IUS1)=DMB(ISU1)
65325 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
65327 C.. *** Tunneling factors for Diquark production***
65328 C.. T: half a curtain pair = sqrt(curtain pair factor)
65329 IF(MSTJ(12).GE.5) THEN
65331 PMUD1=PYMASS(2103)-PMUD0
65332 PMUS0=PYMASS(3201)-PMUD0
65333 PMUS1=PYMASS(3203)-PMUS0-PMUD0
65334 PMSS1=PYMASS(3303)-PMUS0-PMUD0
65335 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
65336 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
65337 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
65338 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
65339 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
65340 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
65341 QBB(IUD1)=QBB(IUU1)
65343 PAR2M=SQRT(PARJ(2))
65344 PAR3M=SQRT(PARJ(3))
65345 PAR4M=SQRT(PARJ(4))
65346 QBB(ISU0)=PAR2M*PAR3M
65348 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
65350 QBB(ISU1)=PAR4M*QBB(ISU0)
65351 QBB(IUS1)=PAR4M*QBB(IUS0)
65355 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
65356 QBM(ISU0)=QBB(ISU0)
65357 QBM(IUS0)=PARJ(2)*QBB(IUS0)
65358 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
65359 QBM(IUU1)=6D0*QBB(IUU1)
65360 QBM(ISU1)=3D0*QBB(ISU1)
65361 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
65362 QBM(IUD1)=3D0*QBB(IUD1)
65364 C.. Combine T and tau to diquark weight for q-> B+B+..
65366 QBB(I)=QBB(I)*QBM(I)
65369 IF(MSTJ(12).GE.5)THEN
65370 C..New version: tau for rank 0 diquark.
65371 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
65372 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
65373 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
65374 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
65375 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
65376 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
65377 DMB(7+IUD1)=DMB(7+IUU1)/2D0
65379 C..New version: curtain flavour ratios.
65380 C.. s/u for q->B+M+...
65381 C.. s/u for rank 0 diquark: su -> ...M+B+...
65382 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65383 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65384 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65385 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
65386 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
65387 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
65388 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
65390 C..Old version: reset unused rank 0 diquark weights and
65391 C.. unused diquark SU(6) survival weights
65393 IF(MSTJ(12).LT.3) DMB(I)=1D0
65397 C..Old version: Shuffle PARJ(7) into tau
65398 QBM(IUS0)=QBM(IUS0)*PARJ(7)
65399 QBM(ISS1)=QBM(ISS1)*PARJ(7)
65400 QBM(IUS1)=QBM(IUS1)*PARJ(7)
65402 C..Old version: curtain flavour ratios.
65403 C.. s/u for q->B+M+...
65404 C.. s/u for rank 0 diquark: su -> ...M+B+...
65405 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65406 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65407 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65408 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
65409 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
65412 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
65413 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
65415 DMB(7+I)=DMB(7+I)*DMB(I)
65416 DMB(I)=DMB(I)*QBM(I)
65417 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
65418 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
65421 C.. *** Popcorn factors ***
65423 IF(MSTJ(12).LT.5)THEN
65424 C.. Old version: Resulting popcorn weights.
65426 WS=PARF(135)*PARF(138)
65428 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
65430 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
65431 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
65432 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
65433 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
65434 & (1D0+QBB(IUD1)+QBB(IUU1)+
65435 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
65437 C..New version: Store weights for popcorn mesons,
65438 C..get prel. popcorn weights.
65439 DO 150 IPOS=201,1400
65448 IF(MR.EQ.7) PARF(193)=PARJ(10)
65449 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
65450 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65451 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65453 IF(NMES.EQ.1) SQWT=PARJ(2)
65455 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
65456 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
65457 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
65459 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
65460 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
65463 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
65465 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
65466 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
65472 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
65473 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
65474 IF(PJWT.LE.0D0) GOTO 190
65475 IF(PJWT.GT.1D0) PJWT=1D0
65477 IMIX=2*KFQOLD+10*KMUL
65479 IF(KMUL.EQ.2) KFJ=10003
65480 IF(KMUL.EQ.3) KFJ=10001
65481 IF(KMUL.EQ.4) KFJ=20003
65482 IF(KMUL.EQ.5) KFJ=5
65484 KFLA=MAX(KFQOLD,KFQVER)
65485 KFLB=MIN(KFQOLD,KFQVER)
65486 SWT=PARJ(11+KFLA/3+KFLA/4)
65487 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
65489 QWT=SQWT/(2D0+SQWT)
65490 IF(KFQVER.LT.3)THEN
65491 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
65492 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
65494 IF(KFQVER.NE.KFQOLD)THEN
65496 KFM=100*KFLA+10*KFLB+KFJ
65497 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65498 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
65499 WTTOT=WTTOT+PARF(IPOS+IMES)
65502 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
65503 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
65504 IF(ID.EQ.5) DWT=PARF(IMIX)
65506 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65507 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
65508 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
65509 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
65510 PARF(IPOS+5*KMUL+ID)=
65511 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
65513 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
65519 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
65521 IF(MR.EQ.7) PARF(140)=
65522 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
65523 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
65524 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
65530 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
65535 C..Recombine diquark weights to flavour and spin ratios
65536 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
65537 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
65538 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
65539 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
65540 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
65541 PARF(155)=QBB(ISU1)/QBB(ISU0)
65542 PARF(156)=QBB(IUS1)/QBB(IUS0)
65543 PARF(157)=QBB(IUD1)
65545 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
65546 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
65547 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
65548 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
65549 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
65550 PARF(165)=QBM(ISU1)/QBM(ISU0)
65551 PARF(166)=QBM(IUS1)/QBM(IUS0)
65552 PARF(167)=QBM(IUD1)
65554 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
65555 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
65556 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
65557 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
65558 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
65559 PARF(175)=DMB(ISU1)/DMB(ISU0)
65560 PARF(176)=DMB(IUS1)/DMB(IUS0)
65561 PARF(177)=DMB(IUD1)
65563 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
65564 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
65565 PARF(187)=DMB(7+IUD1)
65571 C*********************************************************************
65574 C...Generates transverse momentum according to a Gaussian.
65576 SUBROUTINE PYPTDI(KFL,PX,PY)
65578 C...Double precision and integer declarations.
65579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65580 IMPLICIT INTEGER(I-N)
65581 INTEGER PYK,PYCHGE,PYCOMP
65583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65586 C...Generate p_T and azimuthal angle, gives p_x and p_y.
65588 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
65589 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
65590 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
65591 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
65599 C*********************************************************************
65602 C...Generates the longitudinal splitting variable z.
65604 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
65606 C...Double precision and integer declarations.
65607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65608 IMPLICIT INTEGER(I-N)
65609 INTEGER PYK,PYCHGE,PYCOMP
65611 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65612 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65613 SAVE /PYDAT1/,/PYDAT2/
65615 C...Check if heavy flavour fragmentation.
65619 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
65621 C...Lund symmetric scaling function: determine parameters of shape.
65622 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
65623 &MSTJ(11).GE.4) THEN
65625 IF(MSTJ(91).EQ.1) FA=PARJ(43)
65626 IF(KFLB.GE.10) FA=FA+PARJ(45)
65628 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
65631 IF(KFLA.GE.10) FC=FC-PARJ(45)
65632 IF(KFLB.GE.10) FC=FC+PARJ(45)
65633 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
65635 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
65636 FC=FC+FRED*FBB*PARF(100+KFLH)**2
65639 IF(ABS(FC-1D0).GT.0.01D0) MC=2
65641 C...Determine position of maximum. Special cases for a = 0 or a = c.
65642 IF(FA.LT.0.02D0) THEN
65645 IF(FC.GT.FB) ZMAX=FB/FC
65646 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
65651 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
65652 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
65655 C...Subdivide z range if distribution very peaked near endpoint.
65657 IF(ZMAX.LT.0.1D0) THEN
65663 ZDIVC=ZDIV**(1D0-FC)
65664 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
65666 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
65668 FSCB=SQRT(4D0+(FC/FB)**2)
65669 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
65670 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
65671 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
65672 FINT=1D0+FB*(1D0-ZDIV)
65675 C...Choice of z, preweighted for peaks at low or high z.
65679 IF(FINT*PYR(0).LE.1D0) THEN
65681 ELSEIF(MC.EQ.1) THEN
65685 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
65688 ELSEIF(MMAX.EQ.3) THEN
65689 IF(FINT*PYR(0).LE.1D0) THEN
65691 FPRE=EXP(FB*(Z-ZDIV))
65693 Z=ZDIV+Z*(1D0-ZDIV)
65697 C...Weighting according to correct formula.
65698 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
65699 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
65700 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
65701 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
65702 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
65704 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
65706 FC=PARJ(50+MAX(1,KFLH))
65707 IF(MSTJ(91).EQ.1) FC=PARJ(59)
65709 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
65710 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
65711 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
65712 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
65715 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
65716 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
65723 C*********************************************************************
65726 C...Generates timelike parton showers from given partons.
65728 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
65730 C...Double precision and integer declarations.
65731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65732 IMPLICIT INTEGER(I-N)
65733 INTEGER PYK,PYCHGE,PYCOMP
65734 C...Parameter statement to help give large particle numbers.
65735 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65736 &KEXCIT=4000000,KDIMEN=5000000)
65737 PARAMETER (MAXNUR=1000)
65739 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65744 COMMON/PYINT1/MINT(400),VINT(400)
65745 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
65747 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
65748 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
65749 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
65750 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
65753 C...Check that QMAX not too low.
65754 IF(MSTJ(41).LE.0) THEN
65756 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
65757 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
65759 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
65763 C...Store positions of shower initiating partons.
65765 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
65768 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
65773 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
65774 & .AND.IP2.GE.-80) THEN
65779 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
65787 & '(PYSHOW:) failed to reconstruct showering system')
65788 IF(MSTU(21).GE.1) RETURN
65791 C...Send off to PYPTFS for pT-ordered evolution if requested,
65792 C...if at least 2 partons, and without predefined shower branchings.
65793 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
65798 PTPART(II)=0.5D0*QMAX
65800 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
65804 C...Initialization of cutoff masses etc.
65812 PMTH(1,21)=PYMASS(21)
65813 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
65814 PMTH(3,21)=2D0*PMTH(2,21)
65815 PMTH(4,21)=PMTH(3,21)
65816 PMTH(5,21)=PMTH(3,21)
65817 PMTH(1,22)=PYMASS(22)
65818 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
65819 PMTH(3,22)=2D0*PMTH(2,22)
65820 PMTH(4,22)=PMTH(3,22)
65821 PMTH(5,22)=PMTH(3,22)
65823 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
65824 PMQT1E=MIN(PMQTH1,PARJ(90))
65826 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
65827 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
65830 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
65832 PMTH(1,IFL)=PYMASS(IFL)
65833 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
65834 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
65835 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65836 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65839 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
65840 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
65841 PMTH(1,IFL)=PYMASS(IFL)
65842 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
65843 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
65844 PMTH(4,IFL)=PMTH(3,IFL)
65845 PMTH(5,IFL)=PMTH(3,IFL)
65847 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
65849 ALFM=LOG(PT2MIN/ALAMS)
65851 C...Check on phase space available for emission.
65859 KFLA(I)=IABS(K(IPA(I),2))
65861 C...Special cutoff masses for initial partons (may be a heavy quark,
65862 C...squark, ..., and need not be on the mass shell).
65864 IF(NPA.LE.1) IREF(I)=IR
65865 IF(NPA.GE.2) IREF(I+1)=IR
65869 IF(KFLA(I).LE.8) THEN
65871 IF(MSTJ(41).GE.2) ISCHG(IR)=1
65872 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
65873 & KFLA(I).EQ.17) THEN
65874 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
65875 ELSEIF(KFLA(I).EQ.21) THEN
65877 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
65878 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
65880 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
65883 C...same for QQ~[3S18]
65884 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
65885 & KFLA(I).EQ.9900553)) THEN
65889 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
65891 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
65892 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
65893 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
65894 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65895 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65896 ELSEIF(ISCOL(IR).EQ.1) THEN
65897 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
65898 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
65899 PMTH(4,IR)=PMTH(3,IR)
65900 PMTH(5,IR)=PMTH(3,IR)
65901 ELSEIF(ISCHG(IR).EQ.1) THEN
65902 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
65903 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
65904 PMTH(4,IR)=PMTH(3,IR)
65905 PMTH(5,IR)=PMTH(3,IR)
65907 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
65909 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
65911 PS(J)=PS(J)+P(IPA(I),J)
65914 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
65915 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
65916 IF(NPA.EQ.1) PS(5)=PS(4)
65917 IF(PS(5).LE.PM+PMQT1E) RETURN
65919 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
65922 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
65923 KFSRCE=IABS(K(K(IP1,3),2))
65925 IPAR1=MAX(1,K(IP1,3))
65926 IPAR2=MAX(1,K(IP2,3))
65927 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
65928 & KFSRCE=IABS(K(K(IPAR1,3),2))
65931 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
65932 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
65933 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
65934 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
65935 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
65936 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
65937 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
65938 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
65940 C...Identify two primary showerers.
65942 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
65943 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
65944 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
65945 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
65946 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
65947 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
65948 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
65949 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
65951 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
65952 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
65953 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
65954 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
65955 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
65956 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
65957 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
65958 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
65960 C...Order of showerers. Presence of gluino.
65961 ITYPMN=MIN(ITYPE1,ITYPE2)
65962 ITYPMX=MAX(ITYPE1,ITYPE2)
65964 IF(ITYPE1.GT.ITYPE2) IORD=2
65966 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
65968 C...Check if 3-jet matrix elements to be used.
65971 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
65972 IF(MSTJ(38).NE.0) THEN
65976 ELSEIF(MSTJ(47).GE.6) THEN
65982 C...Vector/axial vector -> q + qbar; q -> q + V.
65983 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
65984 & ITYPES.EQ.3)) THEN
65986 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
65988 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
65989 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
65990 C...gamma*/Z0: assume e+e- initial state if unknown.
65992 IF(KFSRCE.EQ.23) THEN
65993 IANNFL=K(K(IP1,3),3)
65994 IF(IANNFL.NE.0) THEN
65995 KANNFL=IABS(K(IANNFL,2))
65996 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
65999 AI=SIGN(1D0,EI+0.1D0)
66000 VI=AI-4D0*EI*PARU(102)
66001 EF=KCHG(KFLA(1),1)/3D0
66002 AF=SIGN(1D0,EF+0.1D0)
66003 VF=AF-4D0*EF*PARU(102)
66004 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66007 SQWZ=PS(5)*PMAS(23,2)
66008 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66009 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66010 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66011 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66013 ALPHA=VECT/(VECT+AXIV)
66014 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66017 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66018 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66020 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66021 & ITYPES.EQ.1)) THEN
66024 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66025 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66027 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66029 ELSEIF(KFSRCE.EQ.36) THEN
66032 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66033 & ITYPES.EQ.1)) THEN
66036 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66037 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66038 & ITYPES.EQ.3)) THEN
66040 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66041 & ITYPES.EQ.2)) THEN
66043 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66045 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66046 & ITYPES.EQ.2)) THEN
66049 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66050 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66051 & ITYPES.EQ.5)) THEN
66053 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66054 & ITYPES.EQ.2)) THEN
66056 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66057 & ITYPES.EQ.1)) THEN
66060 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66061 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66064 & ITYPES.EQ.2)) THEN
66066 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66067 & ITYPES.EQ.1)) THEN
66070 C...g -> ~g + ~g (eikonal approximation).
66071 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66074 M3JC=5*ICLASS+ICOMBI
66078 C...Find if interference with initial state partons.
66080 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
66081 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
66082 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
66087 KCA=PYCOMP(KFLA(I))
66088 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
66090 IF(KCII(I).NE.0) THEN
66092 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
66093 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
66094 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
66096 IIIS(I,NIIS(I))=ICSI
66101 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
66104 C...Boost interfering initial partons to rest frame
66105 C...and reconstruct their polar and azimuthal angles.
66109 K(N+I,J)=K(IPA(I),J)
66110 P(N+I,J)=P(IPA(I),J)
66114 DO 230 I=3,2+NIIS(1)
66116 K(N+I,J)=K(IIIS(1,I-2),J)
66117 P(N+I,J)=P(IIIS(1,I-2),J)
66121 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66123 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
66124 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
66128 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
66129 & -PS(2)/PS(4),-PS(3)/PS(4))
66130 PHI=PYANGL(P(N+1,1),P(N+1,2))
66131 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
66132 THE=PYANGL(P(N+1,3),P(N+1,1))
66133 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
66134 DO 260 I=3,2+NIIS(1)
66135 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
66136 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
66138 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66139 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
66140 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
66141 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
66145 C...Boost 3 or more partons to their rest frame.
66146 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
66147 &-PS(2)/PS(4),-PS(3)/PS(4))
66149 C...Define imagined single initiator of shower for parton system.
66151 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
66152 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66153 IF(MSTU(21).GE.1) RETURN
66172 C...Loop over partons that may branch.
66175 IF(NPA.EQ.1) IM=NS-1
66178 IF(IM.GT.N) GOTO 600
66181 IF(KSH(IR).EQ.0) GOTO 290
66182 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
66187 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
66188 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66189 IF(MSTU(21).GE.1) RETURN
66192 C...Position of aunt (sister to branching parton).
66193 C...Origin and flavour of daughters.
66196 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
66197 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
66209 K(N+I,2)=K(IPA(I),2)
66211 ELSEIF(KFLM.NE.21) THEN
66214 IREF(N+1-NS)=IREF(IM-NS)
66215 IREF(N+2-NS)=IABS(K(N+2,2))
66216 ELSEIF(K(IM,5).EQ.21) THEN
66224 IREF(N+1-NS)=IABS(K(N+1,2))
66225 IREF(N+2-NS)=IABS(K(N+2,2))
66228 C...Reset flags on daughters and tries made.
66233 KFLD(IP)=IABS(K(N+IP,2))
66234 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
66238 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
66242 C...Maximum virtuality of daughters.
66245 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
66246 P(N+I,5)=MIN(QMAX,PS(5))
66248 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
66249 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
66252 IF(MSTJ(43).LE.2) PEM=V(IM,2)
66253 IF(MSTJ(43).GE.3) PEM=P(IM,4)
66254 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
66255 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
66256 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
66260 IF(ISI(I).EQ.1) THEN
66262 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
66264 V(N+I,5)=P(N+I,5)**2
66267 C...Choose one of the daughters for evolution.
66269 IF(NEP.EQ.1) INUM=1
66271 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
66274 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
66276 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
66282 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
66283 RPM=P(N+I,5)/PMSD(I)
66285 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
66293 C...Cancel choice of predetermined daughter already treated.
66296 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
66297 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
66298 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
66299 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
66300 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
66303 C...Store information on choice of evolving daughter.
66307 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
66310 KFL(I)=IABS(K(IEP(I),2))
66312 ITRY(INUM)=ITRY(INUM)+1
66313 IF(ITRY(INUM).GT.200) THEN
66314 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
66315 IF(MSTU(21).GE.1) RETURN
66319 IF(KSH(IR).EQ.0) GOTO 450
66320 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
66322 C...Check if evolution already predetermined for daughter.
66324 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
66325 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
66326 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
66327 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
66328 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
66330 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
66332 IF(IPSPD.NE.0) ISSET(INUM)=1
66335 C...Select side for interference with initial state partons.
66336 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
66339 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
66341 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
66342 IF(PYR(0).GT.0.5D0) ISII(III)=1
66343 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
66345 IF(PYR(0).GT.0.5D0) ISII(III)=2
66349 C...Calculate allowed z range.
66352 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66355 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
66356 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
66358 IF(MOD(MSTJ(43),2).EQ.1) THEN
66360 ZCE=PMTH(2,22)/PMED
66361 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
66363 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
66364 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
66366 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
66367 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
66368 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
66371 ZCE=MIN(ZCE,0.49991D0)
66372 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
66373 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
66374 P(IEP(1),5)=PMTH(1,IR)
66375 V(IEP(1),5)=P(IEP(1),5)**2
66379 C...Integral of Altarelli-Parisi z kernel for QCD.
66380 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
66381 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
66382 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
66384 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
66385 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
66386 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66387 FBR=6D0*LOG((1D0-ZC)/ZC)
66389 ELSEIF(MSTJ(49).EQ.0) THEN
66390 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
66391 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
66393 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
66394 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
66395 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
66396 ELSEIF(MSTJ(49).EQ.1) THEN
66397 FBR=(1D0-2D0*ZC)/3D0
66398 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
66400 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
66401 ELSEIF(KFL(1).EQ.21) THEN
66402 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
66404 FBR=2D0*LOG((1D0-ZC)/ZC)
66407 C...Reset QCD probability for colourless.
66408 IF(ISCOL(IR).EQ.0) FBR=0D0
66410 C...Integral of Altarelli-Parisi kernel for photon emission.
66412 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
66413 IF(KFL(1).LE.18) THEN
66414 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
66416 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
66419 C...Inner veto algorithm starts. Find maximum mass for evolution.
66420 410 PMS=V(IEP(1),5)
66425 IRI=IREF(IEP(I)-NS)
66426 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
66429 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
66432 C...Select mass for daughter in QCD evolution.
66434 DO 430 IFF=4,MSTJ(45)
66435 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
66437 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66438 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
66439 C...Already predetermined choice.
66440 IF(IPSPD.NE.0) THEN
66441 PMSQCD=P(IPSPD,5)**2
66442 ELSEIF(FBR.LT.1D-3) THEN
66444 ELSEIF(MSTJ(44).LE.0) THEN
66445 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
66446 ELSEIF(MSTJ(44).EQ.1) THEN
66447 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
66449 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
66451 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66452 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
66453 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
66457 C...Select mass for daughter in QED evolution.
66458 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
66459 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66460 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
66461 IF(FBRE.LT.1D-3) THEN
66464 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
66465 & (PARU(101)*FBRE)))
66467 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66468 PMSQED=PMSQED+PMTH(1,IR)**2
66469 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
66471 IF(PMSQED.GT.PMSQCD) THEN
66477 C...Check whether daughter mass below cutoff.
66478 P(IEP(1),5)=SQRT(V(IEP(1),5))
66479 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
66480 P(IEP(1),5)=PMTH(1,IR)
66481 V(IEP(1),5)=P(IEP(1),5)**2
66485 C...Already predetermined choice of z, and flavour in g -> qqbar.
66486 IF(IPSPD.NE.0) THEN
66489 PMSGD1=P(IPSGD1,5)**2
66490 PMSGD2=P(IPSGD2,5)**2
66491 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
66492 & 4D0*PMSGD1*PMSGD2))
66493 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
66494 & PMSGD1+PMSGD2)/ALAMPS
66495 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
66496 IF(KFL(1).NE.21) THEN
66499 K(IEP(1),5)=IABS(K(IPSGD1,2))
66502 C...Select z value of branching: q -> qgamma.
66503 ELSEIF(MCE.EQ.2) THEN
66504 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
66505 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66509 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
66510 ELSEIF(MSTJ(49).EQ.0.AND.
66511 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66512 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66513 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
66514 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
66515 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66519 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
66520 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
66521 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66522 C...Only do z weighting when no ME correction afterwards.
66523 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66525 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
66526 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66527 IF(PYR(0).GT.0.5D0) Z=1D0-Z
66528 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66530 ELSEIF(MSTJ(49).NE.1) THEN
66532 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
66533 KFLB=1+INT(MSTJ(45)*PYR(0))
66534 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66535 IF(PMQ.GE.1D0) GOTO 410
66536 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
66537 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
66538 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
66539 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
66540 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
66542 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
66546 C...Ditto for scalar gluon model.
66547 ELSEIF(KFL(1).NE.21) THEN
66548 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
66550 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
66551 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66554 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66555 KFLB=1+INT(MSTJ(45)*PYR(0))
66556 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66557 IF(PMQ.GE.1D0) GOTO 410
66561 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
66562 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
66563 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66564 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66565 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
66567 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
66568 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
66569 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
66570 IF(PT2APP.LT.PT2MIN) GOTO 410
66571 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
66575 C...Check if z consistent with chosen m.
66576 IF(KFL(1).EQ.21) THEN
66577 IRGD1=IABS(K(IEP(1),5))
66581 IRGD2=IABS(K(IEP(1),5))
66585 ELSEIF(NEP.GE.3) THEN
66587 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66588 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
66590 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
66591 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
66593 IF(MOD(MSTJ(43),2).EQ.1) THEN
66594 PMQTH3=0.5D0*PARJ(82)
66595 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66596 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
66597 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
66598 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
66599 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66603 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
66606 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66607 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66608 ELSEIF(IPSPD.NE.0) THEN
66612 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
66614 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
66616 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66618 C...Width suppression for q -> q + g.
66619 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
66621 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
66625 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
66626 IF(MSTJ(40).EQ.1) THEN
66627 IF(CHI.LT.PYR(0)) GOTO 410
66628 ELSEIF(MSTJ(40).EQ.2) THEN
66629 IF(1D0-CHI.LT.PYR(0)) GOTO 410
66633 C...Three-jet matrix element correction.
66638 C...QED matrix elements: only for massless case so far.
66639 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
66640 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66641 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66642 X3=(1D0-X1)+(1D0-X2)
66644 KI2=K(IPA(3-INUM),2)
66645 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
66646 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
66647 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
66648 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
66649 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66650 ELSEIF(MCE.EQ.2) THEN
66652 C...QCD matrix elements, including mass effects.
66653 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
66657 IF(IR.GE.31.AND.IGM.EQ.0) THEN
66658 C...QCD ME: original parton, first branching.
66659 PM2ME=PMTH(1,63-IR)
66661 ELSEIF(IR.GE.31) THEN
66662 C...QCD ME: original parton, subsequent branchings.
66663 PM2ME=PMTH(1,63-IR)
66664 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66665 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66666 ELSEIF(K(IM,2).EQ.21) THEN
66667 C...QCD ME: secondary partons, first branching.
66670 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
66671 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
66672 & 4D0*PS1ME*PM2ME**2))
66673 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
66675 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66678 C...QCD ME: secondary partons, subsequent branchings.
66680 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66681 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66684 C...Construct ME variables.
66687 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
66688 X2=1D0+R2ME**2-PS1ME/ECMME**2
66689 C...Call ME, with right order important for two inequivalent showerers.
66690 IF(IR.EQ.IORD+30) THEN
66691 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
66693 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
66695 C...Split up total ME when two radiating partons.
66697 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
66698 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
66699 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
66700 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
66701 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
66702 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66703 & MAX(1D-10,2D0-X1-X2)
66704 C...Evaluate shower rate to be compared with.
66705 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
66706 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66707 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
66708 ELSEIF(MSTJ(49).NE.1) THEN
66710 C...Toy model scalar theory matrix elements; no mass effects.
66712 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66713 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66714 X3=(1D0-X1)+(1D0-X2)
66715 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
66717 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
66721 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
66724 C...Impose angular ordering by rejection of nonordered emission.
66725 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
66726 PEMAO=V(IM,1)*P(IM,4)
66727 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
66728 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
66730 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
66731 & .OR.MSTJ(42).EQ.7)) THEN
66733 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
66734 & .OR.MSTJ(42).EQ.6)) THEN
66736 PMDAO=PMTH(2,K(IEP(1),5))
66737 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
66740 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
66741 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
66742 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
66746 440 IF(K(IAOM,5).EQ.22) THEN
66748 IF(K(IAOM,3).LE.NS) MAOM=0
66749 IF(MAOM.EQ.1) GOTO 440
66751 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
66752 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
66753 IF(THE2ID.LT.THE2IM) GOTO 410
66757 C...Impose user-defined maximum angle at first branching.
66758 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
66759 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
66760 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
66761 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66762 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
66763 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66764 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66765 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
66766 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66767 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
66771 C...Impose angular constraint in first branching from interference
66772 C...with initial state partons.
66773 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
66774 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
66775 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
66776 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
66777 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
66778 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
66782 C...End of inner veto algorithm. Check if only one leg evolved so far.
66786 IF(NEP.EQ.1) GOTO 490
66787 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
66790 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
66791 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
66795 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
66799 PMSUM=PMSUM+P(N+I,5)
66801 IF(PMSUM.GE.PS(5)) GOTO 350
66802 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
66805 IF(KSH(IRDA).EQ.0) GOTO 480
66806 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
66807 IF(IRDA.EQ.21) THEN
66808 IRGD1=IABS(K(I1,5))
66812 IRGD2=IABS(K(I1,5))
66815 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66816 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
66818 IF(I1.EQ.N+1) ZM=V(IM,1)
66819 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
66820 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
66821 & 4D0*V(N+1,5)*V(N+2,5))
66822 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
66825 IF(MOD(MSTJ(43),2).EQ.1) THEN
66826 PMQTH3=0.5D0*PARJ(82)
66827 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66828 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
66829 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
66830 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
66831 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66835 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
66838 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
66839 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66843 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66844 & ISSET(1).EQ.0) THEN
66846 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66847 & ISSET(2).EQ.0) THEN
66851 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
66853 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66855 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
66858 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
66859 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
66860 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
66861 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
66862 IF(ISL(1).EQ.1) ISL(2)=0
66863 IF(ISL(1).EQ.0) ISLM=1
66864 IF(ISL(2).EQ.0) ISLM=2
66866 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
66871 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
66872 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
66873 PMQ1=V(N+1,5)/V(IM,5)
66874 PMQ2=V(N+2,5)/V(IM,5)
66875 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
66880 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
66884 C...Accepted branch. Construct four-momentum for initial partons.
66890 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
66892 P(N+1,4)=P(IPA(1),4)
66894 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
66895 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
66898 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
66903 P(N+2,4)=P(IM,5)-PED1
66906 ELSEIF(NEP.GE.3) THEN
66907 C...Rescale all momenta for energy conservation.
66913 P(N+I,J)=P(IPA(I),J)
66916 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66919 FAC=(PS(5)-PQS)/(PES-PQS)
66924 P(N+I,J)=FAC*P(N+I,J)
66926 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)
66929 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66931 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
66933 C...Construct transverse momentum for ordinary branching in shower.
66937 550 LOOPPT=LOOPPT+1
66938 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
66939 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
66940 IF(PZM.LE.0D0) THEN
66942 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
66943 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66944 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
66945 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
66946 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
66947 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
66949 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
66951 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
66954 ELSEIF(PTS.LT.0D0) THEN
66957 PT=SQRT(MAX(0D0,PTS))
66959 C...Global statistics.
66960 MINT(353)=MINT(353)+1
66961 VINT(353)=VINT(353)+PT
66962 IF (MINT(353).EQ.1) VINT(358)=PT
66964 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
66966 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
66967 & .AND.IAU.NE.0) THEN
66968 IF(K(IGM,3).NE.0) MAZIP=1
66970 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
66971 IF(MAZIP.EQ.0) ZAU=0D0
66972 IF(K(IGM,2).NE.21) THEN
66973 HAZIP=2D0*ZAU/(1D0+ZAU**2)
66975 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
66977 IF(K(N+1,2).NE.21) THEN
66978 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
66980 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
66984 C...Find coefficient of azimuthal asymmetry due to soft gluon
66987 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
66988 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
66989 IF(K(IGM,3).NE.0) MAZIC=N+1
66990 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
66991 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
66992 & ZM.GT.0.5D0) MAZIC=N+2
66993 IF(K(IAU,2).EQ.22) MAZIC=0
66995 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
66997 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
66998 IF(MAZIC.EQ.0) ZGM=1D0
66999 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
67000 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
67001 HAZIC=MIN(0.95D0,HAZIC)
67005 C...Construct energies for ordinary branching in shower.
67006 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
67007 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67008 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67009 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67010 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67011 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
67012 P(N+1,4)=PEM*V(IM,1)
67014 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
67015 & SQRT(PMLS)*ZM)/V(IM,5)
67018 C...Already predetermined choice of phi angle or not
67020 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
67022 IF(K(IPSPD,4).GT.0) THEN
67024 IF(IM.EQ.NS+2) THEN
67025 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67027 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
67030 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
67032 IF(K(IPSPD,4).GT.0) THEN
67034 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
67035 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
67036 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
67037 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
67038 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67039 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
67043 C...Construct momenta for ordinary branching in shower.
67044 P(N+1,1)=PT*COS(PHI)
67045 P(N+1,2)=PT*SIN(PHI)
67046 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67047 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67048 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67049 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67050 ELSEIF(PZM.GT.0D0) THEN
67051 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
67052 & 2D0*PEM*P(N+1,4))/PZM
67058 P(N+2,3)=PZM-P(N+1,3)
67059 P(N+2,4)=PEM-P(N+1,4)
67060 IF(MSTJ(43).LE.2) THEN
67061 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
67062 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
67066 C...Rotate and boost daughters.
67068 IF(MSTJ(43).LE.2) THEN
67069 BEX=P(IGM,1)/P(IGM,4)
67070 BEY=P(IGM,2)/P(IGM,4)
67071 BEZ=P(IGM,3)/P(IGM,4)
67072 GA=P(IGM,4)/P(IGM,5)
67073 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
67082 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
67083 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
67084 IF(PTIMB.GT.1D-4) THEN
67085 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
67090 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
67091 & SIN(THE)*COS(PHI)*P(I,3)
67092 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
67093 & SIN(THE)*SIN(PHI)*P(I,3)
67094 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
67096 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
67097 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
67098 P(I,1)=DP(1)+DGABP*BEX
67099 P(I,2)=DP(2)+DGABP*BEY
67100 P(I,3)=DP(3)+DGABP*BEZ
67101 P(I,4)=GA*(DP(4)+DBP)
67105 C...Weight with azimuthal distribution, if required.
67106 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
67112 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
67113 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
67114 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
67116 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
67117 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
67119 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
67120 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
67121 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
67122 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
67123 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
67124 IF(MAZIP.NE.0) THEN
67125 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
67128 IF(MAZIC.NE.0) THEN
67129 IF(MAZIC.EQ.N+2) CAD=-CAD
67130 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
67131 & .LT.PYR(0)) GOTO 560
67136 C...Azimuthal anisotropy due to interference with initial state partons.
67137 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
67138 &K(N+2,2).EQ.21)) THEN
67140 IF(ISII(III).GE.1) THEN
67142 IF(K(N+1,2).NE.21) IAZIID=N+2
67143 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67144 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
67145 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
67146 IF(III.EQ.2) THEIID=PARU(1)-THEIID
67147 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
67148 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
67149 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
67150 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
67151 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
67152 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
67153 & .LT.PYR(0)) GOTO 560
67157 C...Continue loop over partons that may branch, until none left.
67158 IF(IGM.GE.0) K(IM,1)=14
67161 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
67162 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
67163 IF(MSTU(21).GE.1) N=NS
67164 IF(MSTU(21).GE.1) RETURN
67168 C...Set information on imagined shower initiator.
67169 600 IF(NPA.GE.2) THEN
67173 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
67181 C...Reconstruct string drawing information.
67182 DO 610 I=NS+1+IIM,N
67183 KQ=KCHG(PYCOMP(K(I,2)),2)
67184 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
67186 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
67187 & IABS(K(I,2)).LE.18) THEN
67189 ELSEIF(K(I,1).LE.10) THEN
67190 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
67191 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
67192 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
67193 ID1=MOD(K(I,4),MSTU(5))
67194 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
67195 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
67196 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
67197 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
67198 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67199 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
67200 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67201 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
67202 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
67203 K(ID2,5)=K(ID2,5)+MSTU(5)*I
67205 ID1=MOD(K(I,4),MSTU(5))
67207 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67208 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
67209 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
67210 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67211 K(ID1,5)=K(ID1,5)+MSTU(5)*I
67221 C...Transformation from CM frame.
67223 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
67224 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
67226 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
67227 ELSEIF(NPA.EQ.2) THEN
67232 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
67233 & /(1D0+GA)-P(IPA(1),4))
67234 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
67235 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
67236 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
67238 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
67240 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
67243 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
67246 C...Decay vertex of shower.
67253 C...Delete trivial shower, else connect initiators.
67254 IF(N.LE.NS+NPA+IIM) THEN
67259 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
67260 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
67261 K(NS+IIM+IP,3)=IPA(IP)
67262 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
67263 IF(K(NS+IIM+IP,1).NE.1) THEN
67264 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
67265 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
67273 C*********************************************************************
67276 C...Generates pT-ordered timelike final-state parton showers.
67278 C...MODE defines how to find radiators and recoilers.
67279 C... = 0 : based on colour flow between undecayed partons.
67280 C... = 1 : for IPART <= NPARTD only consider primary partons,
67281 C... whether decayed or not; else as above.
67282 C... = 2 : based on common history, whether decayed or not.
67284 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
67286 C...Double precision and integer declarations.
67287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67288 IMPLICIT INTEGER(I-N)
67289 INTEGER PYK,PYCHGE,PYCOMP
67290 C...Parameter statement to help give large particle numbers.
67291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67292 &KEXCIT=4000000,KDIMEN=5000000)
67293 C...Parameter statement for maximum size of showers.
67294 PARAMETER (MAXNUR=1000)
67296 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
67297 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67298 COMMON/PYCTAG/NCT,MCT(4000,2)
67299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67301 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
67302 COMMON/PYINT1/MINT(400),VINT(400)
67303 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
67306 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
67307 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
67308 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
67309 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
67310 C...Statement functions.
67311 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
67312 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
67314 C...Initial values. Check that valid system.
67316 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
67317 &MSTJ(41).NE.12) RETURN
67318 IF(NPART.LE.0) THEN
67319 CALL PYERRM(2,'(PYPTFS:) showering system too small')
67324 C...Mass thresholds and Lambda for QCD evolution.
67328 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
67329 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
67336 C...Cutoff scale for QCD evolution. Starting pT2.
67337 NFLAV=MAX(0,MIN(5,MSTJ(45)))
67338 PT0C=0.5D0*PARJ(82)
67339 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
67341 C...Parameters for QED evolution.
67342 AEM2PI=PARU(101)/PARU(2)
67343 PT0EQ=0.5D0*PARJ(83)
67344 PT0EL=0.5D0*PARJ(90)
67346 C...Reset. Remove irrelevant colour tags.
67351 DO 110 I=MINT(84)+1,N
67352 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
67356 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
67363 C...Begin loop to set up showering partons. Sum four-momenta.
67366 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
67367 IF(K(I,1).GT.10) GOTO 210
67368 ELSEIF(K(I,3).GT.MINT(84)) THEN
67369 IF(K(I,3).GT.MINT(84)+2) GOTO 210
67371 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
67374 PSUM(J)=PSUM(J)+P(I,J)
67377 C...Find colour and charge, but skip diquarks.
67378 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
67379 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
67380 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
67382 C...Either colour or anticolour charge radiates; for gluon both.
67383 DO 160 JSGCOL=1,-1,-2
67384 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
67385 JCOL=4+(1-JSGCOL)/2
67388 C...Basic info about radiating parton.
67392 ISCOL(NEVOL)=JSGCOL
67394 PTSCA(NEVOL)=PTPART(IP)
67396 C...Begin search for colour recoiler when MODE = 0 or 1.
67398 C...Find sister with matching anticolour to the radiating parton.
67400 IRNEW=K(IROLD,JCOL)/MSTU(5)
67403 C...The following will add MCT colour tracing for unprepped events
67404 C...If not done, trace Les Houches colour tags for this dipole
67405 C IF (MCT(I,JCOL-3).EQ.0) THEN
67406 C CALL PYCTTR(I,JCOL,INEW)
67407 C...Clean up mother/daughter 'read' tags set by PYCTTR
67409 C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
67410 C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
67414 C...Skip radiation off loose colour ends.
67415 130 IF(IRNEW.EQ.0) THEN
67419 C...Optionally skip radiation on dipole to beam remnant.
67420 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
67424 C...For now always skip radiation on dipole to junction.
67425 ELSEIF(K(IRNEW,2).EQ.88) THEN
67429 C...For MODE=1: if reached primary then done.
67430 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
67431 & IRNEW.LE.NPARTD) THEN
67433 C...If sister stable and points back then done.
67434 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67436 IF(K(IRNEW,1).LT.10) THEN
67438 C...If sister unstable then go to her daughter.
67441 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67446 C...If found mother then look for aunt.
67447 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67450 IRNEW=K(IROLD,JCOL)/MSTU(5)
67453 C...If daughter stable then done.
67454 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67456 IF(K(IRNEW,1).LT.10) THEN
67458 C...If daughter unstable then go to granddaughter.
67461 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67466 C...If daughter points to another daughter then done or move up.
67467 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67469 IF(K(IRNEW,1).LT.10) THEN
67472 IRNEW=K(IRNEW,JCOL)/MSTU(5)
67478 C...Begin search for colour recoiler when MODE = 2.
67481 IRNEW=K(IROLD,JCOL)/MSTU(5)
67482 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
67483 C...Step up to mother if radiating parton already branched.
67484 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
67486 IRNEW=K(IROLD,JCOL)/MSTU(5)
67488 C...Pick sister by history if no anticolour available.
67490 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67492 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
67495 C...Last resort: pick at random among other primaries.
67497 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67498 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67502 C...Trace down if sister branched.
67503 150 IF(K(IRNEW,1).GT.10) THEN
67504 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67509 C...Now found other end of colour dipole.
67514 C...Also electrical charge may radiate; so far only quarks and leptons.
67515 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
67516 & IABS(K(I,2)).LE.18) THEN
67518 C...Basic info about radiating parton.
67524 PTSCA(NEVOL)=PTPART(IP)
67526 C...Pick nearest (= smallest invariant mass) charged particle
67527 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
67531 DO 170 IP2=1,NPART+N-MINT(53)
67532 IF(IP2.EQ.IP) GOTO 170
67533 IF(IP2.LE.NPART) THEN
67535 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
67536 IF(K(I2,1).GT.10) GOTO 170
67537 ELSEIF(K(I2,3).GT.MINT(84)) THEN
67538 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
67540 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
67543 I2=MINT(53)+IP2-NPART
67545 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
67546 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
67547 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
67548 IF(PM2INV.LT.PM2MIN) THEN
67553 IF(IRNEW.EQ.0) THEN
67558 C...Begin search for charge recoiler when MODE = 2.
67561 C...Pick sister by history; step up if parton already branched.
67562 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
67566 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67568 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
67570 C...Last resort: pick at random among other primaries.
67572 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67573 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67575 C...Trace down if sister branched.
67576 190 IF(K(IRNEW,1).GT.10) THEN
67577 DO 200 IR=IRNEW+1,N
67578 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
67588 C...End loop to set up showering partons. System invariant mass.
67590 IF(NEVOL.LE.0) RETURN
67591 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
67593 C...Check if 3-jet matrix elements to be used.
67597 IF(MSTJ(47).GE.1) THEN
67599 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
67601 IPART1=K(IPART(1),3)
67602 IPART2=K(IPART(2),3)
67603 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
67604 KFSRCE=IABS(K(IPART1,2))
67605 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
67608 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
67613 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
67614 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
67615 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
67616 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
67617 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
67618 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
67619 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
67620 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
67622 C...Identify two primary showerers.
67623 KFLA1=IABS(K(IPART(1),2))
67625 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
67626 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
67627 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
67628 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
67629 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
67630 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
67631 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
67632 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
67633 KFLA2=IABS(K(IPART(2),2))
67635 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
67636 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
67637 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
67638 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
67639 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
67640 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
67641 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
67642 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
67644 C...Order of showerers. Presence of gluino.
67645 ITYPMN=MIN(ITYPE1,ITYPE2)
67646 ITYPMX=MAX(ITYPE1,ITYPE2)
67648 IF(ITYPE1.GT.ITYPE2) IORD=2
67650 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
67652 C...Require exactly two primary showerers for ME corrections.
67654 IF(IPART1.GT.0) THEN
67656 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
67659 IF(NPRIM.NE.2) THEN
67661 C...Predetermined and default matrix element kinds.
67662 ELSEIF(MSTJ(38).NE.0) THEN
67666 ELSEIF(MSTJ(47).GE.6) THEN
67672 C...Vector/axial vector -> q + qbar; q -> q + V.
67673 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
67674 & ITYPES.EQ.3)) THEN
67676 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
67678 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
67679 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
67680 C...gamma*/Z0: assume e+e- initial state if unknown.
67682 IF(KFSRCE.EQ.23) THEN
67684 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67685 IF(IANNFL.GT.0) THEN
67686 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67688 IF(IANNFL.NE.0) THEN
67689 KANNFL=IABS(K(IANNFL,2))
67690 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
67693 AI=SIGN(1D0,EI+0.1D0)
67694 VI=AI-4D0*EI*PARU(102)
67695 EF=KCHG(KFLA1,1)/3D0
67696 AF=SIGN(1D0,EF+0.1D0)
67697 VF=AF-4D0*EF*PARU(102)
67698 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
67701 SQWZ=PSUM(5)*PMAS(23,2)
67702 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
67703 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
67704 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
67705 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
67707 ALPHA=VECT/(VECT+AXIV)
67708 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
67711 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
67712 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
67714 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67715 & ITYPES.EQ.1)) THEN
67718 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
67719 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
67721 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
67723 ELSEIF(KFSRCE.EQ.36) THEN
67726 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67727 & ITYPES.EQ.1)) THEN
67730 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
67731 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67732 & ITYPES.EQ.3)) THEN
67734 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67735 & ITYPES.EQ.2)) THEN
67737 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
67739 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67740 & ITYPES.EQ.2)) THEN
67743 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
67744 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67745 & ITYPES.EQ.5)) THEN
67747 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67748 & ITYPES.EQ.2)) THEN
67750 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67751 & ITYPES.EQ.1)) THEN
67754 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
67755 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
67757 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67758 & ITYPES.EQ.2)) THEN
67760 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67761 & ITYPES.EQ.1)) THEN
67764 C...g -> ~g + ~g (eikonal approximation).
67765 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
67768 M3JC=5*ICLASS+ICOMBI
67771 C...Store pair that together define matrix element treatment.
67774 MESYS(NMESYS,0)=M3JC
67775 MESYS(NMESYS,1)=IPART(1)
67776 MESYS(NMESYS,2)=IPART(2)
67779 C...Store qqbar or l+l- pairs for QED radiation.
67780 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
67782 MESYS(NMESYS,0)=101
67783 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
67784 MESYS(NMESYS,1)=IPART(1)
67785 MESYS(NMESYS,2)=IPART(2)
67788 C...Store other qqbar/l+l- pairs from g/gamma branchings.
67790 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
67792 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
67796 C...Move up this check to avoid out-of-bounds.
67797 IF(I1M.EQ.0) GOTO 270
67798 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
67800 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
67802 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
67806 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
67812 MESYS(NMESYS,0)=102
67820 C..Loopback point for counting number of emissions.
67824 C...Begin loop to evolve all existing partons, if required.
67827 DO 360 IEVOL=1,NEVOL
67828 IF(IFLG(IEVOL).EQ.0) THEN
67830 C...Basic info on radiator and recoil.
67837 C...Invariant mass of "dipole".Starting value for pT evolution.
67838 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
67839 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
67841 C...Case of evolution by QCD branching.
67842 IF(ISCOL(IEVOL).NE.0) THEN
67844 C...Parton-by-parton maximum scale from initial conditions.
67845 IF(MSTP(72).EQ.0) THEN
67846 DO 300 IPRT=1,NPARTS
67847 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
67851 C...If kinematically impossible then do not evolve.
67852 IF(PT2.LT.PT2CMN) THEN
67857 C...Check if part of system for which ME corrections should be applied.
67859 DO 310 IME=1,NMESYS
67860 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67861 & MESYS(IME,0).LT.100) IMESYS=IME
67864 C...Special flag for colour octet states.
67866 IF(K(I,2).EQ.21) MOCT=1
67867 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
67869 C...Upper estimate for matrix element weighting and colour factor.
67870 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
67873 IF(MOCT.GE.1) COLFAC=3D0/2D0
67874 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
67875 WTPSQQ=0.5D0*0.5D0*NFLAV
67877 C...Determine overestimated z range: switch at c and b masses.
67882 IF(PT2.GT.1.01D0*PMCS) THEN
67888 IF(PT2.GT.1.01D0*PMBS) THEN
67894 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
67895 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
67897 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
67898 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
67901 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
67902 EVCOEF=EVCOEF+EVEMQQ
67905 C...Pick pT2 (in overestimated z range).
67906 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
67908 C...Loopback if crossed c/b mass thresholds.
67909 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
67913 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
67918 C...Finish if below lower cutoff.
67919 IF(PT2.LT.PT2CMN) THEN
67924 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
67926 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
67928 C...Pick z: dz/(1-z) or dz.
67929 IF(IFLAG.EQ.1) THEN
67930 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
67932 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
67935 C...Loopback if outside allowed range for given pT2.
67936 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
67937 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
67938 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
67939 PM2=PM2I+PT2/(Z*(1D0-Z))
67940 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
67942 C...No weighting for primary partons; to be done later on.
67943 IF(IMESYS.GT.0) THEN
67945 C...Weighting of q->qg/X->Xg branching.
67946 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
67947 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
67949 C...Weighting of g->gg branching.
67950 ELSEIF(IFLAG.EQ.1) THEN
67951 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
67953 C...Flavour choice and weighting of g->qqbar branching.
67955 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
67957 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
67958 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
67959 IF(WTME.LT.PYR(0)) GOTO 330
67963 C...Case of evolution by QED branching.
67964 ELSEIF(ISCHG(IEVOL).NE.0) THEN
67966 C...If kinematically impossible then do not evolve.
67968 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
67969 IF(PT2.LT.PT2EMN) THEN
67974 C...Check if part of system for which ME corrections should be applied.
67976 DO 340 IME=1,NMESYS
67977 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67978 & MESYS(IME,0).GT.100) IMESYS=IME
67981 C...Charge. Matrix element weighting factor.
67982 CHG=ISCHG(IEVOL)/3D0
67985 C...Determine overestimated z range. Find evolution coefficient.
67986 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
67987 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
67988 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
67990 C...Pick pT2 (in overestimated z range).
67991 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
67993 C...Finish if below lower cutoff.
67994 IF(PT2.LT.PT2EMN) THEN
67999 C...Pick z: dz/(1-z).
68000 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
68002 C...Loopback if outside allowed range for given pT2.
68003 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
68004 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
68005 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
68006 PM2=PM2I+PT2/(Z*(1D0-Z))
68007 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
68009 C...Weighting by branching kernel, except if ME weighting later.
68010 IF(IMESYS.EQ.0) THEN
68011 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
68016 C...Save acceptable branching.
68018 IMESAV(IEVOL)=IMESYS
68024 C...Check if branching has highest pT.
68025 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
68027 PT2MX=PT2SAV(IEVOL)
68031 C...Finished if no more branchings to be done.
68032 IF(IMX.EQ.0) GOTO 480
68034 C...Restore info on hardest branching to be processed.
68045 PM2=PM2I+PT2/(Z*(1D0-Z))
68047 C...Special flag for colour octet states.
68049 IF(K(I,2).EQ.21) MOCT=1
68050 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
68052 C...Restore further info for g->qqbar branching.
68054 IF(IFLG(IMX).GT.10) THEN
68057 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
68060 C...For branching g include azimuthal asymmetries from polarization.
68062 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
68063 C...Trace grandmother via intermediate recoil copies.
68066 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
68067 & K(IM,3).GT.0) THEN
68069 IF(IM.GT.MINT(84)) GOTO 370
68072 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
68073 & KFGM=IABS(K(IGM,2))
68074 C...Define approximate energy sharing by identifying aunt.
68076 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
68077 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
68078 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
68079 C...Coefficient from gluon production.
68081 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
68083 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
68085 C...Coefficient from gluon decay.
68087 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
68089 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
68094 C...Create new slots for branching products and recoil.
68100 C...Set status, flavour and mother of new ones.
68103 IF(KCHA.NE.0) K(IGNEW,1)=1
68108 IF(KCHA.NE.0) K(IGNEW,2)=22
68110 K(INEW,2)=-ISIGN(KFQ,KCOL)
68111 K(IGNEW,2)=-K(INEW,2)
68118 C...Find rest frame and angles of branching+recoil.
68124 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
68125 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
68126 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
68127 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
68128 PHI=PYANGL(P(INEW,1),P(INEW,2))
68129 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
68131 C...Derive kinematics of branching: generics (like g->gg).
68136 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
68137 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
68138 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
68139 PTCOR=SQRT(MAX(0D0,PT2COR))
68140 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
68141 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
68142 C...Specific kinematics reduction for q->qg with m_q > 0.
68144 PTCOR=(1D0-PM2I/PM2)*PTCOR
68145 PZN=PZN+PM2I*PZG/PM2
68146 PZG=(1D0-PM2I/PM2)*PZG
68147 C...Specific kinematics reduction for g->qqbar with m_q > 0.
68148 ELSEIF(KFQ.NE.0) THEN
68152 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
68156 C...Pick phi and construct kinematics of branching.
68157 400 PHIROT=PARU(2)*PYR(0)
68158 P(INEW,1)=PTCOR*COS(PHIROT)
68159 P(INEW,2)=PTCOR*SIN(PHIROT)
68161 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
68162 P(IGNEW,1)=-P(INEW,1)
68163 P(IGNEW,2)=-P(INEW,2)
68165 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
68169 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
68171 C...Boost branching system to lab frame.
68172 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
68174 C...Renew choice of phi angle according to polarization asymmetry.
68175 IF(ABS(ASYPOL).GT.1D-3) THEN
68181 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
68182 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
68183 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
68185 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
68186 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
68188 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
68189 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
68190 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
68191 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
68192 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
68193 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
68198 C...Matrix element corrections for primary partons when requested.
68199 IF(IMESYS.GT.0) THEN
68200 M3JC=MESYS(IMESYS,0)
68202 C...Identify recoiling partner and set up three-body kinematics.
68203 IRP=MESYS(IMESYS,1)
68204 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
68205 IF(IRP.EQ.IR) IRP=IRNEW
68207 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
68209 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
68211 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
68212 & PSUM(3)*P(INEW,3))/PSUM(5)**2
68213 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
68214 & PSUM(3)*P(IRP,3))/PSUM(5)**2
68216 R1ME=P(INEW,5)/PSUM(5)
68217 R2ME=P(IRP,5)/PSUM(5)
68219 C...Matrix elements for gluon emission.
68220 IF(M3JC.LT.100) THEN
68222 C...Call ME, with right order important for two inequivalent showerers.
68223 IF(MESYS(IMESYS,IORD).EQ.I) THEN
68224 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
68226 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
68229 C...Split up total ME when two radiating partons.
68231 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
68232 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
68233 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
68234 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
68235 & MAX(1D-10,2D0-X1-X2)
68237 C...Evaluate shower rate.
68238 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68239 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68240 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
68242 C...Matrix elements for photon emission: still rather primitive.
68245 C...For generic charge combination currently only massless expression.
68246 IF(M3JC.EQ.101) THEN
68247 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
68248 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
68249 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
68250 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
68252 C...For flavour neutral system assume vector source and include masses.
68254 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
68255 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
68256 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68257 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68261 C...Perform weighting with W_ME/W_PS.
68262 IF(WME.LT.PYR(0)*WPS) THEN
68270 C...Now for sure accepted branching. Save highest pT.
68271 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
68273 C...Update status for obsolete ones. Bookkkep the moved original parton
68274 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
68275 C...Do not bookkeep radiated photon, since it cannot radiate further.
68279 IF(IPART(IP).EQ.I) IPART(IP)=INEW
68280 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
68287 C...Initialize colour flow of branching.
68288 C...Use both old and new style colour tags for flexibility.
68302 C...Trivial colour flow for l->lgamma and q->qgamma.
68303 IF(IABS(KCHA).EQ.3) THEN
68306 ELSEIF(KCHA.NE.0) THEN
68307 IF(K(I,4).NE.0) THEN
68309 K(INEW,4)=MSTU(5)*I
68310 MCT(INEW,1)=MCT(I,1)
68312 IF(K(I,5).NE.0) THEN
68314 K(INEW,5)=MSTU(5)*I
68315 MCT(INEW,2)=MCT(I,2)
68318 C...Set colour flow for q->qg and g->gg.
68319 ELSEIF(KFQ.EQ.0) THEN
68320 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68321 K(IGNEW,JCOLP)=MSTU(5)*I
68322 K(INEW,JCOLP)=MSTU(5)*IGNEW
68323 K(IGNEW,JCOLN)=MSTU(5)*INEW
68324 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68326 MCT(INEW,JCOLP-3)=NCT
68327 MCT(IGNEW,JCOLN-3)=NCT
68329 K(I,JCOLN)=K(I,JCOLN)+INEW
68330 K(INEW,JCOLN)=MSTU(5)*I
68331 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68334 C...Set colour flow for g->qqbar.
68336 K(I,JCOLN)=K(I,JCOLN)+INEW
68337 K(INEW,JCOLN)=MSTU(5)*I
68338 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68339 K(IGNEW,JCOLP)=MSTU(5)*I
68340 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68341 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68344 C...Daughter info for colourless recoiling parton.
68345 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
68351 C...Colour of recoiling parton sails through unchanged.
68353 IF(K(IR,4).NE.0) THEN
68354 K(IR,4)=K(IR,4)+IRNEW
68355 K(IRNEW,4)=MSTU(5)*IR
68356 MCT(IRNEW,1)=MCT(IR,1)
68358 IF(K(IR,5).NE.0) THEN
68359 K(IR,5)=K(IR,5)+IRNEW
68360 K(IRNEW,5)=MSTU(5)*IR
68361 MCT(IRNEW,2)=MCT(IR,2)
68365 C...Vertex information trivial.
68372 C...Update list of old radiators.
68373 DO 460 IEVOL=1,NEVOL
68374 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
68376 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
68379 ELSEIF(IPOS(IEVOL).EQ.I) THEN
68382 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
68385 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
68387 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
68391 C...Update links of old connected partons.
68392 IF(IREC(IEVOL).EQ.I) THEN
68395 ELSEIF(IREC(IEVOL).EQ.IR) THEN
68401 C...q->qg or g->gg: create new gluon radiators.
68402 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
68409 PTSCA(NEVOL)=SQRT(PT2)
68416 PTSCA(NEVOL)=PTSCA(NEVOL-1)
68419 C...Update matrix elements parton list and add new for g/gamma->qqbar.
68420 DO 470 IME=1,NMESYS
68421 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
68422 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
68423 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
68424 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
68429 MESYS(NMESYS,1)=INEW
68430 MESYS(NMESYS,2)=IGNEW
68432 MESYS(NMESYS,0)=102
68433 MESYS(NMESYS,1)=INEW
68434 MESYS(NMESYS,2)=IGNEW
68437 C...Global statistics.
68438 MINT(353)=MINT(353)+1
68439 VINT(353)=VINT(353)+PTCOR
68440 IF (MINT(353).EQ.1) VINT(358)=PTCOR
68442 C...Loopback for more emissions if enough space.
68444 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
68445 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
68448 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
68457 C*********************************************************************
68460 C...Auxiliary to PYSHOW and PYPTFS.
68461 C...Matrix elements for gluon (or photon) emission from
68462 C...a two-body state; to be used by the parton shower routine.
68463 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
68464 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
68465 C... = (alpha-strong/2 pi) * CF * PYMAEL,
68466 C...i.e. normalization is such that one recovers the familiar
68467 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
68468 C...Coupling structure:
68469 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
68470 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
68471 C... = 16-19 : q -> q V
68472 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
68473 C... = 26-29 : q -> q S
68474 C... = 31-34 : V -> ~q ~qbar (~q = squark)
68475 C... = 36-39 : ~q -> ~q V
68476 C... = 41-44 : S -> ~q ~qbar
68477 C... = 46-49 : ~q -> ~q S
68478 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
68479 C... = 56-59 : ~q -> q chi
68480 C... = 61-64 : q -> ~q chi
68481 C... = 66-69 : ~g -> q ~qbar
68482 C... = 71-74 : ~q -> q ~g
68483 C... = 76-79 : q -> ~q ~g
68484 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
68485 C...Note that the order of the decay products is important.
68486 C...In each set of four, the variants are ordered as:
68487 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
68488 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
68489 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
68490 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
68492 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
68494 C...Double precision and integer declarations.
68495 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68496 IMPLICIT INTEGER(I-N)
68498 C...Check input values. Return zero outside allowed phase space.
68500 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
68501 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
68502 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
68503 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
68504 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
68505 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
68507 C...Initial values and flags.
68515 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
68517 C...Eikonal expression; also acts as default.
68518 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
68520 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
68522 ELSEIF(ICOMBI.EQ.2) THEN
68523 ANUM=(2D0-X1-X2)**2
68524 ELSEIF(ICOMBI.EQ.3) THEN
68525 ANUM=ALPCOR*(2D0-X1-X2)**2
68527 ANUM=0.5D0*(2D0-X1-X2)**2
68529 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
68530 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
68531 & R1**2/(1D0+R2**2-R1**2-X2)**2-
68532 & R2**2/(1D0+R1**2-R2**2-X1)**2)
68535 C...V -> q qbar (V = gamma*/Z0/W+-/...).
68536 ELSEIF(ICLASS.EQ.2) THEN
68537 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68538 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68539 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
68540 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
68541 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
68542 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
68543 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68544 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
68545 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
68546 & (-1+R1**2-R2**2+X2)**2
68547 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68548 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68549 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
68550 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68551 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
68552 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68553 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68554 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
68555 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
68556 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
68557 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
68558 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
68562 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68563 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68564 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
68565 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
68566 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
68567 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
68568 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
68569 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
68570 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
68571 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68572 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68573 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
68574 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68575 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
68576 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68577 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68578 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
68579 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
68580 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
68581 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68582 & +X2)/(-1-R1**2+R2**2+X1)**2
68586 IF(ICOMBI.EQ.4) THEN
68587 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
68588 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
68589 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
68590 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
68591 & (-1-R1**2+R2**2+X1)**2
68593 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
68594 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
68595 & -R1**2*X2**2+X1*X2**2)/
68596 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68597 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
68598 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
68599 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
68600 & (-1+R1**2-R2**2+X2)**2
68606 ELSEIF(ICLASS.EQ.3) THEN
68607 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68608 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
68609 & +R1**2*R2**2-2D0*R2**4)
68610 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
68611 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
68612 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
68613 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
68614 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
68615 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
68616 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68617 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
68618 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68619 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
68620 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68621 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68622 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
68623 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
68624 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68625 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
68626 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68627 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
68628 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
68631 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68632 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
68633 & +R1**2*R2**2-2D0*R2**4)
68634 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
68635 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
68636 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
68637 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
68638 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
68639 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
68640 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68641 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
68642 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68643 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
68644 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68645 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68646 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68647 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
68648 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68649 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
68650 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68651 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68652 & +X1*X2**2)/(-2+X1+X2)**2
68655 IF(ICOMBI.EQ.4) THEN
68656 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
68657 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
68658 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
68659 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
68660 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
68661 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68662 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
68663 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
68664 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68665 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68666 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68667 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
68668 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
68669 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68670 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68671 & +X1*X2**2)/(2-X1-X2)**2
68675 C...S -> q qbar (S = h0/H0/A0/H+-/...).
68676 ELSEIF(ICLASS.EQ.4) THEN
68677 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68678 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
68679 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68680 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68681 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68682 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
68683 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
68684 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68685 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68686 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68687 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68690 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68691 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
68692 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68693 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68694 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68695 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68696 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68697 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68698 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
68699 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
68700 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
68701 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68704 IF(ICOMBI.EQ.4) THEN
68705 RLO4=PS*(1D0-R1**2-R2**2)
68706 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
68707 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68708 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
68709 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
68710 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68711 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
68712 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68717 ELSEIF(ICLASS.EQ.5) THEN
68718 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68719 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68720 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68721 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68722 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
68723 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68724 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68725 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68726 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68727 & (-1+R1**2-R2**2+X2)**2
68730 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68731 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68732 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68733 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68734 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
68735 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68736 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68737 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68738 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68739 & (-1+R1**2-R2**2+X2)**2
68742 IF(ICOMBI.EQ.4) THEN
68743 RLO4=PS*(1D0+R1**2-R2**2)
68744 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
68745 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68746 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
68747 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68748 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68749 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68753 C...V -> ~q ~qbar (~q = squark).
68754 ELSEIF(ICLASS.EQ.6) THEN
68755 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68756 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
68757 & (-1-R1**2+R2**2+X1)**2
68758 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
68759 & (-1-R1**2+R2**2+X1)
68760 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
68761 & /(-1+R1**2-R2**2+X2)**2
68762 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
68763 & (-1+R1**2-R2**2+X2)
68764 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
68765 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
68766 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
68767 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68771 ELSEIF(ICLASS.EQ.7) THEN
68772 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68773 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
68774 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
68775 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
68776 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68777 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
68778 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
68779 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
68780 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
68781 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
68782 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
68788 ELSEIF(ICLASS.EQ.8) THEN
68790 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68791 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
68792 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
68793 & -R1**2*X2**2+X1*X2**2)/
68794 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
68799 ELSEIF(ICLASS.EQ.9) THEN
68801 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68802 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68803 & -(X1+X2)/(-2+X1+X2)**2
68806 C...chi -> q ~qbar (chi = neutralino/chargino).
68807 ELSEIF(ICLASS.EQ.10) THEN
68808 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68809 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68810 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68811 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
68812 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68813 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68814 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68815 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68816 & (-1+R1**2-R2**2+X2)**2
68819 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68820 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
68821 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
68822 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
68823 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
68824 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68825 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68826 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68827 & (-1+R1**2-R2**2+X2)**2
68830 IF(ICOMBI.EQ.4) THEN
68831 RLO4=PS*(1+R1**2-R2**2)
68832 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68833 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
68834 & +X2+R1**2*X2-X1*X2/2)/
68835 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68836 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68837 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68842 ELSEIF(ICLASS.EQ.11) THEN
68843 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68844 RLO1=PS*(1D0-(R1+R2)**2)
68845 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68846 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68847 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68848 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68849 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68850 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68851 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68854 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68855 RLO2=PS*(1D0-(R1-R2)**2)
68856 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
68858 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68859 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68860 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68861 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
68862 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68863 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68866 IF(ICOMBI.EQ.4) THEN
68867 RLO4=PS*(1D0-R1**2-R2**2)
68868 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68869 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
68870 & +3*R1**2*X2-R2**2*X2-X1*X2)/
68871 & (-1+R1**2-R2**2+X2)**2
68872 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
68873 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
68874 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68879 ELSEIF(ICLASS.EQ.12) THEN
68880 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68881 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
68882 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68883 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
68884 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
68885 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
68886 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68887 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68890 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68891 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
68892 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
68893 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
68894 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
68895 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
68896 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68897 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68900 IF(ICOMBI.EQ.4) THEN
68901 RLO4=PS*(1D0-R1**2+R2**2)
68902 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68903 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
68904 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
68905 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
68906 & +R1**2*X2-X1*X2/2-X2**2/2)/
68907 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68912 ELSEIF(ICLASS.EQ.13) THEN
68913 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68914 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68915 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
68916 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
68917 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
68918 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
68919 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68920 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
68921 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
68922 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
68923 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
68924 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
68925 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
68926 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68927 & (3*(-1+R1**2-R2**2+X2)**2)
68931 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68932 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68933 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
68934 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
68935 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
68936 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
68937 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
68938 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
68939 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
68940 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
68941 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
68942 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68943 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
68944 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
68945 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68946 & (3*(-1+R1**2-R2**2+X2)**2)
68950 IF(ICOMBI.EQ.4) THEN
68951 RLO4=PS*(1D0+R1**2-R2**2)
68952 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
68953 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
68954 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
68955 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
68956 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
68957 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68958 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
68959 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68960 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
68961 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68962 & (3*(-1+R1**2-R2**2+X2)**2)
68968 ELSEIF(ICLASS.EQ.14) THEN
68969 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68970 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
68971 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68972 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68973 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68974 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
68975 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
68976 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
68977 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
68978 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68979 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68980 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
68981 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
68982 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
68983 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
68985 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68986 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68987 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
68991 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68992 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
68993 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68994 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68995 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68996 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
68997 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
68998 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
68999 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
69000 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
69001 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
69002 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69004 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
69005 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
69006 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69007 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
69008 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
69009 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69013 IF(ICOMBI.EQ.4) THEN
69014 RLO4=PS*(1-R1**2-R2**2)
69015 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
69016 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
69017 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
69018 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
69019 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
69020 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
69021 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
69022 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69023 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
69024 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
69025 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
69026 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
69027 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
69028 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
69029 RFO4=9D0*RFO4/128D0
69034 ELSEIF(ICLASS.EQ.15) THEN
69035 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69036 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
69037 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69038 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
69039 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
69040 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
69041 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
69042 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69043 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
69044 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
69045 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69046 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
69047 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
69048 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
69049 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69050 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69054 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69055 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
69056 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
69057 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
69058 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
69059 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
69060 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
69061 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69062 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
69063 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
69064 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69065 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
69066 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
69067 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
69068 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
69069 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69073 IF(ICOMBI.EQ.4) THEN
69074 RLO4=PS*(1D0-R1**2+R2**2)
69075 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69076 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
69077 & -R2**2*X2/2-X1*X2/2)/
69078 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
69079 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
69080 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69081 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
69082 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69083 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
69084 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
69085 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69086 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69091 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
69092 ELSEIF(ICLASS.EQ.16) THEN
69094 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
69096 ELSEIF(ICOMBI.EQ.2) THEN
69097 ANUM=(2D0-X1-X2)**2
69098 ELSEIF(ICOMBI.EQ.3) THEN
69099 ANUM=ALPCOR*(2D0-X1-X2)**2
69101 ANUM=0.5D0*(2D0-X1-X2)**2
69103 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
69104 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
69105 & R1**2/(1D0+R2**2-R1**2-X2)**2-
69106 & R2**2/(1D0+R1**2-R2**2-X1)**2)
69111 C...Find relevant LO and FO expression.
69112 IF(ICOMBI.EQ.0) THEN
69113 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
69116 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
69119 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69120 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
69121 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
69122 ELSEIF(ISSET4.EQ.1) THEN
69125 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69126 RLO=0.5D0*(RLO1+RLO2)
69127 RFO=0.5D0*(RFO1+RFO2)
69128 ELSEIF(ISSET1.EQ.1) THEN
69132 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
69143 C*********************************************************************
69146 C...Modifies an event so as to approximately take into account
69147 C...Bose-Einstein effects according to a simple phenomenological
69148 C...parametrization.
69150 SUBROUTINE PYBOEI(NSAV)
69152 C...Double precision and integer declarations.
69153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69154 IMPLICIT INTEGER(I-N)
69155 INTEGER PYK,PYCHGE,PYCOMP
69156 C...Parameter statement to help give large particle numbers.
69157 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69158 &KEXCIT=4000000,KDIMEN=5000000)
69160 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69163 COMMON/PYINT1/MINT(400),VINT(400)
69164 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
69165 C...Local arrays and data.
69166 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
69167 &BEIW(100),BEI3W(100)
69168 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
69169 C...Statement function: squared invariant mass.
69170 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
69171 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
69173 C...Boost event to overall CM frame. Calculate CM energy.
69174 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
69180 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
69181 & .AND.K(I,3).GT.0) THEN
69182 KFMA=IABS(K(K(I,3),2))
69183 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
69185 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
69187 DPS(J)=DPS(J)+P(I,J)
69190 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
69194 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
69197 C...Check if we have separated strings
69199 C...Reserve copy of particles by species at end of record.
69205 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
69206 NBE(IBE)=NBE(IBE-1)
69208 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
69209 DO 140 IIBE=1,IBE-1
69210 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
69213 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
69215 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
69216 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
69217 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
69220 NBE(IBE)=NBE(IBE)+1
69227 P(NBE(IBE),1)=0.0D0
69228 P(NBE(IBE),2)=0.0D0
69229 P(NBE(IBE),3)=0.0D0
69230 P(NBE(IBE),4)=0.0D0
69231 P(NBE(IBE),5)=0.0D0
69232 SMMIN=MIN(SMMIN,P(I,5))
69233 C...Check if particles comes from different W's or Z's
69234 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
69236 150 IF(K(IM,3).GT.0) THEN
69238 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
69240 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
69241 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
69242 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
69243 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
69246 C...Check if particles comes from different strings.
69247 IF(PARJ(94).GT.0.0D0) THEN
69249 160 IF(K(IM,3).GT.0) THEN
69251 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
69259 P(NBE(IBE),5)=-1.0D0
69262 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
69264 C...Calculate separation between W+ and W- or between two Z0's.
69265 C...No separation if there has been re-connections.
69267 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
69268 IF(K(IWP,2).EQ.23) THEN
69277 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
69278 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
69279 TAUP=-TAUPD*LOG(PYR(IDUM))
69280 TAUN=-TAUND*LOG(PYR(IDUM))
69281 DXP=TAUP*PYP(IWP,8)/DMP
69282 DXN=TAUN*PYP(IWN,8)/DMN
69284 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
69285 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
69288 C...Add separation between strings.
69289 IF(PARJ(94).GT.0.0D0) THEN
69290 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
69295 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
69296 DO 220 IBE=1,MIN(9,MSTJ(52))
69297 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
69300 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
69301 IF(I2M.EQ.I1M) GOTO 200
69303 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
69304 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
69305 & (P(I1,5)+P(I2,5))**2
69306 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
69315 C...Tabulate integral for subsequent momentum shift.
69316 DO 400 IBE=1,MIN(9,MSTJ(52))
69317 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
69318 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
69320 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
69321 & NBE(7)-NBE(6)).LE.1) GOTO 270
69322 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
69323 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
69324 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
69325 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
69326 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
69327 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
69328 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
69329 QDELW=0.1D0*MIN(PMHQ,SIGW)
69330 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
69331 IF(MSTJ(51).EQ.1) THEN
69332 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
69333 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
69334 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
69335 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
69336 BEEX=EXP(0.5D0*QDEL/PARJ(93))
69337 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
69338 BEEXW=EXP(0.5D0*QDELW/SIGW)
69339 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
69340 BERT=EXP(-QDEL/PARJ(93))
69341 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
69342 BERTW=EXP(-QDELW/SIGW)
69343 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
69345 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
69346 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
69347 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
69348 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
69351 QBIN=QDEL*(IBIN-0.5D0)
69352 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69353 IF(MSTJ(51).EQ.1) THEN
69355 BEI(IBIN)=BEI(IBIN)*BEEX
69357 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
69359 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
69361 DO 240 IBIN=1,NBIN3
69362 QBIN=QDEL3*(IBIN-0.5D0)
69363 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69364 IF(MSTJ(51).EQ.1) THEN
69366 BEI3(IBIN)=BEI3(IBIN)*BEEX3
69368 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
69370 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
69372 DO 250 IBIN=1,NBINW
69373 QBIN=QDELW*(IBIN-0.5D0)
69374 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69375 IF(MSTJ(51).EQ.1) THEN
69377 BEIW(IBIN)=BEIW(IBIN)*BEEXW
69379 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
69381 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
69383 DO 260 IBIN=1,NBIN3W
69384 QBIN=QDEL3W*(IBIN-0.5D0)
69385 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
69386 & SQRT(QBIN**2+PMHQ**2)
69387 IF(MSTJ(51).EQ.1) THEN
69388 BEEX3W=BEEX3W*BERT3W
69389 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
69391 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
69393 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
69396 C...Loop through particle pairs and find old relative momentum.
69397 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
69399 DO 380 I2M=I1M+1,NBE(IBE)
69400 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
69401 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
69403 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
69404 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
69405 IF(Q2OLD.LE.0.0D0) GOTO 380
69408 C...Calculate new relative momentum.
69413 IF(QOLD.LT.1D-3*QDEL) THEN
69415 ELSEIF(QOLD.LE.QDEL) THEN
69417 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
69420 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
69421 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
69422 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69424 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69426 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
69427 IF(QOLD.LT.1D-3*QDEL3) THEN
69429 ELSEIF(QOLD.LE.QDEL3) THEN
69431 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
69434 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
69435 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
69436 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69438 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69440 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
69443 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
69444 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
69445 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
69447 IF(QOLD.LT.1D-3*QDELW) THEN
69449 ELSEIF(QOLD.LE.QDELW) THEN
69451 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
69454 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
69455 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
69456 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69458 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69460 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
69461 IF(QOLD.LT.1D-3*QDEL3W) THEN
69463 ELSEIF(QOLD.LE.QDEL3W) THEN
69465 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
69468 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
69469 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
69470 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69472 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69474 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
69476 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
69478 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
69480 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
69481 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
69483 IF(MSTJ(54).GE.1) THEN
69484 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
69486 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
69487 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
69489 ELSEIF(MSTJ(54).LE.-1) THEN
69490 EDEL=P(I1,4)+P(I2,4)-
69491 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
69492 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69493 & (P(I1,3)-P(I2,3))**2
69498 SM1=(P(I1,5)+SMMIN)**2
69499 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69500 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
69501 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
69502 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69503 & K(I3M,5).NE.K(I1M,5)) GOTO 360
69505 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
69508 SM3=(P(I3,5)+SMMIN)**2
69509 IF(MSTJ(54).EQ.-2) THEN
69510 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
69511 & S23*MIN(SM1,SM3))*SM1)
69513 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
69514 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
69515 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
69516 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
69518 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
69519 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
69522 IF(WMAX*WI.GE.1.0) GOTO 360
69524 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
69525 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
69526 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
69527 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69528 & K(I4M,5).NE.K(I1M,5)) GOTO 350
69530 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
69532 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
69533 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69534 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
69536 IF(MSTJ(54).EQ.-2) THEN
69540 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
69541 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
69542 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
69543 W=MIN(W,MIN(S23,S24)*S13*S14)
69546 C...weight=1-cos(theta)/mtot2
69547 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
69548 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
69549 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
69550 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
69552 IF(W.LE.WMAX) GOTO 350
69554 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
69555 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
69556 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
69557 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
69558 IF(W.LE.WMAX) GOTO 350
69564 IF(MI4.EQ.0) GOTO 380
69567 EOLD=P(I3,4)+P(I4,4)
69569 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69570 & (P(I3,3)+P(I4,3))**2
69571 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
69572 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
69573 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
69575 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
69576 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
69583 C...Shift momenta and recalculate energies.
69587 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69591 P(I,J)=P(I,J)+P(IM,J)
69593 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69596 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69601 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
69602 440 ALPHA=(ESUMP-ESUM)/PROD
69603 PARJ(96)=PARJ(96)+ALPHA
69606 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69609 P(I,J)=P(I,J)+ALPHA*V(IM,J)
69611 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69614 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69617 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
69621 C...Rescale all momenta for energy conservation.
69625 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
69627 PQS=PQS+P(I,5)**2/P(I,4)
69630 FAC=(PECM-PQS)/(PES-PQS)
69632 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
69636 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69639 C...Boost back to correct reference frame.
69640 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
69642 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
69648 C*********************************************************************
69651 C...Calculates the momentum shift in a system of two particles assuming
69652 C...the relative momentum squared should be shifted to Q2NEW. NI is the
69653 C...last position occupied in /PYJETS/.
69655 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
69657 C...Double precision and integer declarations.
69658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69659 IMPLICIT INTEGER(I-N)
69660 INTEGER PYK,PYCHGE,PYCOMP
69661 C...Parameter statement to help give large particle numbers.
69662 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69663 &KEXCIT=4000000,KDIMEN=5000000)
69665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69667 SAVE /PYJETS/,/PYDAT1/
69668 C...Local arrays and data.
69672 IF(MSTJ(55).EQ.0) THEN
69674 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69675 & (P(I1,3)-P(I2,3))**2
69676 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
69677 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
69681 DA=SE*DE*DP12-DP2*DQ2SE
69682 DB=DP2*DQ2SE-DP12**2
69683 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
69685 PD=HA*(P(I1,J)-P(I2,J))
69697 DP(J)=P(I1,J)+P(I2,J)
69700 C...Boost to cms and rotate first particle to z-axis
69701 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
69702 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
69703 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
69704 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
69705 S=Q2NEW+(P(I1,5)+P(I2,5))**2
69706 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
69710 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
69714 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
69715 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
69716 CALL PYROBO(NI+1,NI+2,THE,PHI,
69717 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
69720 P(NI+1,J)=P(NI+1,J)-P(I1,J)
69721 P(NI+2,J)=P(NI+2,J)-P(I2,J)
69727 C*********************************************************************
69730 C...Gives the mass of a particle/parton.
69732 FUNCTION PYMASS(KF)
69734 C...Double precision and integer declarations.
69735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69736 IMPLICIT INTEGER(I-N)
69737 INTEGER PYK,PYCHGE,PYCOMP
69739 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69740 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69741 SAVE /PYDAT1/,/PYDAT2/
69743 C...Reset variables. Compressed code. Special case for popcorn diquarks.
69752 C...Guarantee use of constituent masses for internal checks.
69753 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
69754 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
69756 PYMASS=PARF(100+KFA)
69757 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
69758 ELSEIF(KFA.LE.10) THEN
69760 ELSEIF(MSTJ(93).EQ.1) THEN
69761 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
69763 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
69766 C...Other masses can be read directly off table.
69771 C...Optional mass broadening according to truncated Breit-Wigner
69772 C...(either in m or in m^2).
69773 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
69774 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
69775 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
69776 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
69779 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
69780 & (PM0*PMAS(KC,2)))
69781 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
69782 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
69783 & (PMUPP-PMLOW)*PYR(0))))
69791 C*********************************************************************
69794 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
69795 C...for Higgs couplings. Everything else sent on to PYMASS.
69797 FUNCTION PYMRUN(KF,Q2)
69799 C...Double precision and integer declarations.
69800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69801 IMPLICIT INTEGER(I-N)
69802 INTEGER PYK,PYCHGE,PYCOMP
69804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69806 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69807 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
69809 C...Most masses not handled here.
69811 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
69814 C...Current-algebra masses, but no Q2 dependence.
69815 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
69816 PYMRUN=PARF(90+KFA)
69818 C...Running current-algebra masses.
69821 PYMRUN=PARF(90+KFA)*
69822 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
69823 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
69829 C*********************************************************************
69832 C...Gives the particle/parton name as a character string.
69834 SUBROUTINE PYNAME(KF,CHAU)
69836 C...Double precision and integer declarations.
69837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69838 IMPLICIT INTEGER(I-N)
69839 INTEGER PYK,PYCHGE,PYCOMP
69841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69843 COMMON/PYDAT4/CHAF(500,2)
69845 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
69846 C...Local character variable.
69849 C...Read out code with distinction particle/antiparticle.
69852 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
69858 C*********************************************************************
69861 C...Gives three times the charge for a particle/parton.
69863 FUNCTION PYCHGE(KF)
69865 C...Double precision and integer declarations.
69866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69867 IMPLICIT INTEGER(I-N)
69868 INTEGER PYK,PYCHGE,PYCOMP
69870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69873 C...Read out charge and change sign for antiparticle.
69876 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
69881 C*********************************************************************
69884 C...Compress the standard KF codes for use in mass and decay arrays;
69885 C...also checks whether a given code actually is defined.
69887 FUNCTION PYCOMP(KF)
69889 C...Double precision and integer declarations.
69890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69891 IMPLICIT INTEGER(I-N)
69892 INTEGER PYK,PYCHGE,PYCOMP
69894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69895 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69896 SAVE /PYDAT1/,/PYDAT2/
69897 C...Local arrays and saved data.
69898 DIMENSION KFORD(100:500),KCORD(101:500)
69899 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
69901 C...Whenever necessary reorder codes for faster search.
69902 IF(MSTU(20).EQ.0) THEN
69907 IF(KFA.LE.100) GOTO 120
69909 DO 100 I1=NFORD-1,0,-1
69910 IF(KFA.GE.KFORD(I1)) GOTO 110
69911 KFORD(I1+1)=KFORD(I1)
69912 KCORD(I1+1)=KCORD(I1)
69914 110 KFORD(I1+1)=KFA
69922 C...Fast action if same code as in latest call.
69923 IF(KF.EQ.KFLAST) THEN
69928 C...Starting values. Remove internal diquark flags.
69931 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
69932 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
69934 C...Simple cases: direct translation.
69935 IF(KFA.GT.KFORD(NFORD)) THEN
69936 ELSEIF(KFA.LE.100) THEN
69939 C...Else binary search.
69943 130 IAVG=(IMIN+IMAX)/2
69944 IF(KFORD(IAVG).GT.KFA) THEN
69946 IF(IMAX.GT.IMIN+1) GOTO 130
69947 ELSEIF(KFORD(IAVG).LT.KFA) THEN
69949 IF(IMAX.GT.IMIN+1) GOTO 130
69955 C...Check if antiparticle allowed.
69956 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
69957 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
69960 C...Save codes for possible future fast action.
69967 C*********************************************************************
69970 C...Informs user of errors in program execution.
69972 SUBROUTINE PYERRM(MERR,CHMESS)
69974 C...Double precision and integer declarations.
69975 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69976 IMPLICIT INTEGER(I-N)
69977 INTEGER PYK,PYCHGE,PYCOMP
69979 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69980 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69981 SAVE /PYJETS/,/PYDAT1/
69982 C...Local character variable.
69983 CHARACTER CHMESS*(*)
69985 C...Write first few warnings, then be silent.
69986 IF(MERR.LE.10) THEN
69987 MSTU(27)=MSTU(27)+1
69989 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
69990 & MERR,MSTU(31),CHMESS
69992 C...Write first few errors, then be silent or stop program.
69993 ELSEIF(MERR.LE.20) THEN
69994 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
69995 MSTU(30)=MSTU(30)+1
69997 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
69998 & MERR-10,MSTU(31),CHMESS
69999 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
70000 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
70001 WRITE(MSTU(11),5200)
70002 IF(MERR.NE.17) CALL PYLIST(2)
70006 C...Stop program in case of irreparable error.
70008 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
70012 C...Formats for output.
70013 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
70014 &' PYEXEC calls:'/5X,A)
70015 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
70016 &' PYEXEC calls:'/5X,A)
70017 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
70019 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
70020 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
70025 C*********************************************************************
70028 C...Calculates the running alpha_electromagnetic.
70030 FUNCTION PYALEM(Q2)
70032 C...Double precision and integer declarations.
70033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70034 IMPLICIT INTEGER(I-N)
70035 INTEGER PYK,PYCHGE,PYCOMP
70037 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70040 C...Calculate real part of photon vacuum polarization.
70041 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
70042 C...For hadrons use parametrization of H. Burkhardt et al.
70043 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
70044 AEMPI=PARU(101)/(3D0*PARU(1))
70045 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
70047 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
70049 ELSEIF(MSTU(101).EQ.2) THEN
70050 RPIGG=1D0-PARU(101)/PARU(103)
70051 ELSEIF(Q2.LT.0.09D0) THEN
70052 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
70053 ELSEIF(Q2.LT.9D0) THEN
70054 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
70055 & 0.00238D0*LOG(1D0+3.927D0*Q2)
70056 ELSEIF(Q2.LT.1D4) THEN
70057 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
70058 & 0.00299D0*LOG(1D0+Q2)
70060 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
70061 & 0.00293D0*LOG(1D0+Q2)
70064 C...Calculate running alpha_em.
70065 PYALEM=PARU(101)/(1D0-RPIGG)
70071 C*********************************************************************
70074 C...Gives the value of alpha_strong.
70076 FUNCTION PYALPS(Q2)
70078 C...Double precision and integer declarations.
70079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70080 IMPLICIT INTEGER(I-N)
70081 INTEGER PYK,PYCHGE,PYCOMP
70083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70084 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70085 SAVE /PYDAT1/,/PYDAT2/
70086 C...Coefficients for second-order threshold matching.
70087 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
70088 DIMENSION STEPDN(6),STEPUP(6)
70089 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
70090 c &(2D0*321D0/3703D0),0D0/
70091 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
70092 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
70093 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
70094 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
70096 C...Constant alpha_strong trivial. Pick artificial Lambda.
70097 IF(MSTU(111).LE.0) THEN
70099 MSTU(118)=MSTU(112)
70101 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
70102 & ((33D0-2D0*MSTU(112))*PARU(111)))
70103 PARU(118)=PARU(111)
70107 C...Find effective Q2, number of flavours and Lambda.
70109 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
70112 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
70113 Q2THR=PARU(113)*PMAS(NF,1)**2
70114 IF(Q2EFF.LT.Q2THR) THEN
70117 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
70118 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
70122 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
70123 Q2THR=PARU(113)*PMAS(NF+1,1)**2
70124 IF(Q2EFF.GT.Q2THR) THEN
70127 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
70128 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
70132 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
70133 PARU(117)=SQRT(ALAM2)
70135 C...Evaluate first or second order alpha_strong.
70136 B0=(33D0-2D0*NF)/6D0
70137 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
70138 IF(MSTU(111).EQ.1) THEN
70139 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
70141 B1=(153D0-19D0*NF)/6D0
70142 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
70151 C*********************************************************************
70154 C...Reconstructs an angle from given x and y coordinates.
70156 FUNCTION PYANGL(X,Y)
70158 C...Double precision and integer declarations.
70159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70160 IMPLICIT INTEGER(I-N)
70161 INTEGER PYK,PYCHGE,PYCOMP
70163 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70168 IF(R.LT.1D-20) RETURN
70169 IF(ABS(X)/R.LT.0.8D0) THEN
70170 PYANGL=SIGN(ACOS(X/R),Y)
70173 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
70174 PYANGL=PARU(1)-PYANGL
70175 ELSEIF(X.LT.0D0) THEN
70176 PYANGL=-PARU(1)-PYANGL
70183 C*********************************************************************
70186 C...Performs rotations and boosts.
70188 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
70190 C...Double precision and integer declarations.
70191 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70192 IMPLICIT INTEGER(I-N)
70193 INTEGER PYK,PYCHGE,PYCOMP
70195 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70196 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70197 SAVE /PYJETS/,/PYDAT1/
70199 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
70201 C...Find and check range of rotation/boost.
70203 IF(IMIN.LE.0) IMIN=1
70204 IF(MSTU(1).GT.0) IMIN=MSTU(1)
70206 IF(IMAX.LE.0) IMAX=N
70207 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70208 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
70209 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
70213 C...Optional resetting of V (when not set before.)
70214 IF(MSTU(33).NE.0) THEN
70215 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
70223 C...Rotate, typically from z axis to direction (theta,phi).
70224 IF(THE**2+PHI**2.GT.1D-20) THEN
70225 ROT(1,1)=COS(THE)*COS(PHI)
70227 ROT(1,3)=SIN(THE)*COS(PHI)
70228 ROT(2,1)=COS(THE)*SIN(PHI)
70230 ROT(2,3)=SIN(THE)*SIN(PHI)
70235 IF(K(I,1).LE.0) GOTO 140
70241 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
70242 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
70247 C...Boost, typically from rest to momentum/energy=beta.
70248 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
70252 DB=SQRT(DBX**2+DBY**2+DBZ**2)
70254 IF(DB.GT.EPS1) THEN
70255 C...Rescale boost vector if too close to unity.
70256 CALL PYERRM(3,'(PYROBO:) boost vector too large')
70262 DGA=1D0/SQRT(1D0-DB**2)
70264 IF(K(I,1).LE.0) GOTO 160
70269 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
70270 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
70271 P(I,1)=DP(1)+DGABP*DBX
70272 P(I,2)=DP(2)+DGABP*DBY
70273 P(I,3)=DP(3)+DGABP*DBZ
70274 P(I,4)=DGA*(DP(4)+DBP)
70275 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
70276 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
70277 V(I,1)=DV(1)+DGABV*DBX
70278 V(I,2)=DV(2)+DGABV*DBY
70279 V(I,3)=DV(3)+DGABV*DBZ
70280 V(I,4)=DGA*(DV(4)+DBV)
70287 C*********************************************************************
70290 C...Performs global manipulations on the event record, in particular
70291 C...to exclude unstable or undetectable partons/particles.
70293 SUBROUTINE PYEDIT(MEDIT)
70295 C...Double precision and integer declarations.
70296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70297 IMPLICIT INTEGER(I-N)
70298 INTEGER PYK,PYCHGE,PYCOMP
70299 C...Parameter statement to help give large particle numbers.
70300 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70301 &KEXCIT=4000000,KDIMEN=5000000)
70303 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70306 COMMON/PYCTAG/NCT,MCT(4000,2)
70307 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
70309 DIMENSION NS(2),PTS(2),PLS(2)
70311 C...Remove unwanted partons/particles.
70312 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
70314 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70315 I1=MAX(1,MSTU(1))-1
70316 DO 110 I=MAX(1,MSTU(1)),IMAX
70317 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
70318 IF(MEDIT.EQ.1) THEN
70319 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70320 ELSEIF(MEDIT.EQ.2) THEN
70321 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70323 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70324 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70325 & K(I,2).EQ.KSUSY1+39) GOTO 110
70326 ELSEIF(MEDIT.EQ.3) THEN
70327 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70329 IF(KC.EQ.0) GOTO 110
70330 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
70331 ELSEIF(MEDIT.EQ.5) THEN
70332 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
70334 IF(KC.EQ.0) GOTO 110
70335 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
70336 & KCHG(KC,2).EQ.0) GOTO 110
70339 C...Pack remaining partons/particles. Origin no longer known.
70348 IF(I1.LT.N) MSTU(3)=0
70349 IF(I1.LT.N) MSTU(70)=0
70352 C...Selective removal of class of entries. New position of retained.
70353 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
70356 K(I,3)=MOD(K(I,3),MSTU(5))
70357 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
70358 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
70359 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
70360 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
70361 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
70362 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
70363 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
70365 K(I,3)=K(I,3)+MSTU(5)*I1
70368 C...Find new event history information and replace old.
70370 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
70371 & K(I,3)/MSTU(5).EQ.0) GOTO 140
70373 130 IM=MOD(K(ID,3),MSTU(5))
70374 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
70375 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
70376 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
70380 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
70381 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
70382 & K(IM,2).EQ.94) THEN
70387 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
70388 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
70389 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
70390 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
70391 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
70392 & K(K(I,4),3)/MSTU(5)
70393 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
70394 & K(K(I,5),3)/MSTU(5)
70396 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
70397 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
70398 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
70399 KCD=MOD(K(I,4),MSTU(5))
70400 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70401 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70402 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
70403 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
70404 KCD=MOD(K(I,5),MSTU(5))
70405 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70406 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70410 C...Pack remaining entries.
70415 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
70422 C...Also update LHA1 colour tags
70425 K(I1,3)=MOD(K(I1,3),MSTU(5))
70427 IF(I.EQ.MSTU(90+IZ)) THEN
70428 MSTU(90)=MSTU(90)+1
70429 MSTU(90+MSTU(90))=I1
70430 PARU(90+MSTU(90))=PARU(90+IZ)
70434 IF(I1.LT.N) MSTU(3)=0
70435 IF(I1.LT.N) MSTU(70)=0
70438 C...Fill in some missing daughter pointers (lost in colour flow).
70439 ELSEIF(MEDIT.EQ.16) THEN
70441 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
70442 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
70443 C...Find daughters who point to mother.
70445 IF(K(I1,3).NE.I) THEN
70446 ELSEIF(K(I,4).EQ.0) THEN
70452 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70453 IF(K(I,4).NE.0) GOTO 220
70454 C...Find daughters who point to documentation version of mother.
70456 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
70457 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
70458 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
70460 IF(K(I1,3).NE.IM) THEN
70461 ELSEIF(K(I,4).EQ.0) THEN
70467 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70468 IF(K(I,4).NE.0) GOTO 220
70469 C...Find daughters who point to documentation daughters who,
70470 C...in their turn, point to documentation mother.
70474 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
70476 IF(ID1.EQ.IM) ID1=I1
70480 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
70481 ELSEIF(K(I,4).EQ.0) THEN
70487 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70490 C...Save top entries at bottom of PYJETS commonblock.
70491 ELSEIF(MEDIT.EQ.21) THEN
70492 IF(2*N.GE.MSTU(4)) THEN
70493 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
70498 K(MSTU(4)-I,J)=K(I,J)
70499 P(MSTU(4)-I,J)=P(I,J)
70500 V(MSTU(4)-I,J)=V(I,J)
70505 C...Restore bottom entries of commonblock PYJETS to top.
70506 ELSEIF(MEDIT.EQ.22) THEN
70507 DO 260 I=1,MSTU(32)
70509 K(I,J)=K(MSTU(4)-I,J)
70510 P(I,J)=P(MSTU(4)-I,J)
70511 V(I,J)=V(MSTU(4)-I,J)
70516 C...Mark primary entries at top of commonblock PYJETS as untreated.
70517 ELSEIF(MEDIT.EQ.23) THEN
70522 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
70524 IF(KH.NE.0) GOTO 280
70526 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
70527 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
70531 C...Place largest axis along z axis and second largest in xy plane.
70532 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
70533 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
70534 & P(MSTU(61),2)),0D0,0D0,0D0)
70535 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
70536 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
70537 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
70538 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
70539 IF(MEDIT.EQ.31) RETURN
70541 C...Rotate to put slim jet along +z axis.
70548 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
70549 IF(MSTU(41).GE.2) THEN
70551 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70552 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70553 & K(I,2).EQ.KSUSY1+39) GOTO 300
70554 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70557 IS=2D0-SIGN(0.5D0,P(I,3))
70559 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
70561 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
70562 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
70564 C...Rotate to put second largest jet into -z,+x quadrant.
70566 IF(P(I,3).GE.0D0) GOTO 310
70567 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
70568 IF(MSTU(41).GE.2) THEN
70570 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70571 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70572 & K(I,2).EQ.KSUSY1+39) GOTO 310
70573 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70576 IS=2D0-SIGN(0.5D0,P(I,1))
70577 PLS(IS)=PLS(IS)-P(I,3)
70579 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
70586 C*********************************************************************
70589 C...Gives program heading, or lists an event, or particle
70590 C...data, or current parameter values.
70592 SUBROUTINE PYLIST(MLIST)
70594 C...Double precision and integer declarations.
70595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70596 IMPLICIT INTEGER(I-N)
70597 INTEGER PYK,PYCHGE,PYCOMP
70598 C...Parameter statement to help give large particle numbers.
70599 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70600 &KEXCIT=4000000,KDIMEN=5000000)
70602 C...HEPEVT commonblock.
70603 PARAMETER (NMXHEP=4000)
70604 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
70605 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
70606 DOUBLE PRECISION PHEP,VHEP
70609 C...User process event common block.
70611 PARAMETER (MAXNUP=500)
70612 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
70613 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
70614 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
70615 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
70616 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
70620 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70622 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70623 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
70624 COMMON/PYCTAG/NCT,MCT(4000,2)
70625 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
70626 C...Local arrays, character variables and data.
70627 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
70629 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
70631 C...Initialization printout: version number and date of last change.
70632 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
70635 IF(MLIST.EQ.0) RETURN
70638 C...List event data, including additional lines after N.
70639 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
70640 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
70641 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
70642 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
70643 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
70645 IF(MLIST.GE.2) LMX=16
70648 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70649 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
70650 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
70651 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
70652 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
70654 C...Get particle name, pad it and check it is not too long.
70655 CALL PYNAME(K(I,2),CHAP)
70658 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
70662 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
70664 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
70667 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
70669 CHAC=CHDL(MDL)(1:2*LDL)//' '
70671 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
70672 & CHDL(MDL)(LDL+1:2*LDL)//' '
70673 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
70677 C...Add information on string connection.
70678 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
70682 IF(KC.NE.0) KCC=KCHG(KC,2)
70683 IF(IABS(K(I,2)).EQ.39) THEN
70684 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
70685 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
70687 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
70688 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
70689 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
70690 ELSEIF(KCC.NE.0) THEN
70692 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
70695 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
70696 & CHAC(LMX-1:LMX-1)='I'
70698 C...Write data for particle/jet.
70699 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
70700 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
70702 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
70703 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
70705 ELSEIF(MLIST.EQ.1) THEN
70706 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
70708 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
70709 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
70710 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
70711 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70712 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
70714 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
70715 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70716 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
70717 & ,10000),MCT(I,1),MCT(I,2)
70719 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
70721 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
70722 & ,MCT(I,1),MCT(I,2)
70724 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
70726 C...Insert extra separator lines specified by user.
70727 IF(MSTU(70).GE.1) THEN
70729 DO 110 J=1,MIN(10,MSTU(70))
70730 IF(I.EQ.MSTU(70+J)) ISEP=1
70733 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
70734 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
70735 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
70740 C...Sum of charges and momenta.
70744 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
70745 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
70746 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
70747 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
70748 ELSEIF(MLIST.EQ.1) THEN
70749 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
70750 ELSEIF(MLIST.LE.3) THEN
70751 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
70753 WRITE(MSTU(11),7000) PS(6)
70756 C...Simple listing of HEPEVT entries (mainly for test purposes).
70757 ELSEIF(MLIST.EQ.5) THEN
70758 WRITE(MSTU(11),7100)
70760 IF(ISTHEP(I).EQ.0) GOTO 140
70761 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
70762 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
70766 C...Simple listing of user-process entries (mainly for test purposes).
70767 ELSEIF(MLIST.EQ.7) THEN
70768 WRITE(MSTU(11),7300)
70770 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
70771 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
70774 C...Give simple list of KF codes defined in program.
70775 ELSEIF(MLIST.EQ.11) THEN
70776 WRITE(MSTU(11),7500)
70778 CALL PYNAME(KF,CHAP)
70779 CALL PYNAME(-KF,CHAN)
70780 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70781 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70785 DO 170 KFLB=1,KFLA-(3-KFLS)/2
70786 KF=1000*KFLA+100*KFLB+KFLS
70787 CALL PYNAME(KF,CHAP)
70788 CALL PYNAME(-KF,CHAN)
70789 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70795 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
70796 IF(KMUL.EQ.5) KFLS=5
70798 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
70799 IF(KMUL.EQ.4) KFLR=2
70801 DO 200 KFLC=1,KFLB-1
70802 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
70803 CALL PYNAME(KF,CHAP)
70804 CALL PYNAME(-KF,CHAN)
70805 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70808 CALL PYNAME(KFK,CHAP)
70809 WRITE(MSTU(11),7600) KFK,CHAP
70811 CALL PYNAME(KFK,CHAP)
70812 WRITE(MSTU(11),7600) KFK,CHAP
70815 KF=10000*KFLR+110*KFLB+KFLS
70816 CALL PYNAME(KF,CHAP)
70817 WRITE(MSTU(11),7600) KF,CHAP
70821 CALL PYNAME(KF,CHAP)
70822 WRITE(MSTU(11),7600) KF,CHAP
70824 CALL PYNAME(KF,CHAP)
70825 WRITE(MSTU(11),7600) KF,CHAP
70831 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
70833 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
70834 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
70835 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
70836 CALL PYNAME(KF,CHAP)
70837 CALL PYNAME(-KF,CHAN)
70838 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70845 IF(KF.LT.1000000) GOTO 270
70846 CALL PYNAME(KF,CHAP)
70847 CALL PYNAME(-KF,CHAN)
70848 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70849 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70852 C...List parton/particle data table. Check whether to be listed.
70853 ELSEIF(MLIST.EQ.12) THEN
70854 WRITE(MSTU(11),7700)
70855 DO 300 KC=1,MSTU(6)
70857 IF(KF.EQ.0) GOTO 300
70858 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
70861 C...Find particle name and mass. Print information.
70862 CALL PYNAME(KF,CHAP)
70863 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
70864 CALL PYNAME(-KF,CHAN)
70865 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
70866 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
70868 C...Particle decay: channel number, branching ratios, matrix element,
70869 C...decay products.
70870 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
70872 CALL PYNAME(KFDP(IDC,J),CHAD(J))
70874 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
70879 C...List parameter value table.
70880 ELSEIF(MLIST.EQ.13) THEN
70881 WRITE(MSTU(11),8000)
70883 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
70887 C...Format statements for output on unit MSTU(11) (by default 6).
70888 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
70889 &5X,'KF orig p_x p_y p_z E m'/)
70890 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
70891 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70892 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
70893 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
70894 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70895 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
70896 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
70897 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
70898 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
70899 & ,' C tag AC tag'/)
70900 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
70901 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
70902 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
70903 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
70904 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
70905 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
70906 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
70907 6200 FORMAT(66X,5(1X,F12.3))
70908 6300 FORMAT(1X,78('='))
70909 6400 FORMAT(1X,130('='))
70910 6500 FORMAT(1X,65('='))
70911 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
70912 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
70913 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
70914 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
70916 7000 FORMAT(19X,'sum charge:',F6.2)
70917 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
70918 &//' I IST ID Mothers Daughters p_x p_y p_z',
70920 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
70921 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
70922 &//' I IST ID Mothers Colours p_x p_y p_z',
70924 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
70925 7500 FORMAT(///20X,'List of KF codes in program'/)
70926 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
70927 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
70928 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
70929 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
70930 &1X,'ME',3X,'Br.rat.',4X,'decay products')
70931 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
70932 &1X,1P,E13.5,3X,I2)
70933 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
70934 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
70935 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
70936 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
70941 C*********************************************************************
70944 C...Writes a logo for the program.
70948 C...Double precision and integer declarations.
70949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70950 IMPLICIT INTEGER(I-N)
70951 INTEGER PYK,PYCHGE,PYCOMP
70952 C...Parameter for length of information block.
70953 PARAMETER (IREFER=21)
70955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70957 SAVE /PYDAT1/,/PYPARS/
70958 C...Local arrays and character variables.
70960 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
70961 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
70963 C...Data on months, logo, titles, and references.
70964 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
70965 &'Oct','Nov','Dec'/
70966 DATA (LOGO(J),J=1,19)/
70968 &' *:::!!:::::::::::* ',
70969 &' *::::::!!::::::::::::::* ',
70970 &' *::::::::!!::::::::::::::::* ',
70971 &' *:::::::::!!:::::::::::::::::* ',
70972 &' *:::::::::!!:::::::::::::::::* ',
70973 &' *::::::::!!::::::::::::::::*! ',
70974 &' *::::::!!::::::::::::::* !! ',
70975 &' !! *:::!!:::::::::::* !! ',
70976 &' !! !* -><- * !! ',
70986 DATA (LOGO(J),J=20,38)/
70987 &'Welcome to the Lund Monte Carlo!',
70989 &'PPP Y Y TTTTT H H III A ',
70990 &'P P Y Y T H H I A A ',
70991 &'PPP Y T HHHHH I AAAAA',
70992 &'P Y T H H I A A',
70993 &'P Y T H H III A A',
70995 &'This is PYTHIA version x.xxx ',
70996 &'Last date of change: xx xxx 200x',
70998 &'Now is xx xxx 200x at xx:xx:xx ',
71000 &'Disclaimer: this program comes ',
71001 &'without any guarantees. Beware ',
71002 &'of errors and use common sense ',
71003 &'when interpreting results. ',
71005 &'Copyright T. Sjostrand (2007) '/
71006 DATA (REFER(J),J=1,14)/
71007 &'An archive of program versions and d',
71008 &'ocumentation is found on the web: ',
71009 &'http://www.thep.lu.se/~torbjorn/Pyth',
71013 &'When you cite this program, the offi',
71014 &'cial reference is to the 6.4 manual:',
71015 &'T. Sjostrand, S. Mrenna and P. Skand',
71016 &'s, JHEP05 (2006) 026 ',
71017 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
71018 &'-T) [hep-ph/0603175]. ',
71021 DATA (REFER(J),J=15,32)/
71022 &'Also remember that the program, to a',
71023 &' large extent, represents original ',
71024 &'physics research. Other publications',
71025 &' of special relevance to your ',
71026 &'studies may therefore deserve separa',
71030 &'Main author: Torbjorn Sjostrand; CER',
71031 &'N/PH, CH-1211 Geneva, Switzerland, ',
71032 &' and Department of Theoretical Phys',
71033 &'ics, Lund University, Lund, Sweden; ',
71034 &' phone: + 41 - 22 - 767 82 27; e-ma',
71035 &'il: torbjorn@thep.lu.se ',
71036 &'Author: Stephen Mrenna; Computing Di',
71037 &'vision, GDS Group, ',
71038 &' Fermi National Accelerator Laborat',
71039 &'ory, MS 234, Batavia, IL 60510, USA;'/
71040 DATA (REFER(J),J=33,2*IREFER)/
71041 &' phone: + 1 - 630 - 840 - 2556; e-m',
71042 &'ail: mrenna@fnal.gov ',
71043 &'Author: Peter Skands; Theoretical Ph',
71044 &'ysics Department, ',
71045 &' Fermi National Accelerator Laborat',
71046 &'ory, MS 106, Batavia, IL 60510, USA;',
71047 &' and CERN/PH, CH-1211 Geneva, Switz',
71049 &' phone: + 41 - 22 - 767 24 59; e-ma',
71050 &'il: skands@fnal.gov '/
71052 C...Check that PYDATA linked.
71053 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
71055 & 'Error: PYDATA has not been linked.'
71056 WRITE(*,'(1X,A)') 'Execution stopped!'
71059 C...Write current version number and current date+time.
71061 WRITE(VERS,'(I1)') MSTP(181)
71062 LOGO(28)(24:24)=VERS
71063 WRITE(SUBV,'(I3)') MSTP(182)
71064 LOGO(28)(26:28)=SUBV
71065 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
71066 WRITE(DATE,'(I2)') MSTP(185)
71067 LOGO(29)(22:23)=DATE
71068 LOGO(29)(25:27)=MONTH(MSTP(184))
71069 WRITE(YEAR,'(I4)') MSTP(183)
71070 LOGO(29)(29:32)=YEAR
71072 IF(IDATI(1).LE.0) THEN
71075 WRITE(DATE,'(I2)') IDATI(3)
71077 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
71078 WRITE(YEAR,'(I4)') IDATI(1)
71079 LOGO(31)(15:18)=YEAR
71080 WRITE(HOUR,'(I2)') IDATI(4)
71081 LOGO(31)(23:24)=HOUR
71082 WRITE(MINU,'(I2)') IDATI(5)
71083 LOGO(31)(26:27)=MINU
71084 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
71085 WRITE(SECO,'(I2)') IDATI(6)
71086 LOGO(31)(29:30)=SECO
71087 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
71091 C...Loop over lines in header. Define page feed and side borders.
71092 DO 100 ILIN=1,29+IREFER
71101 C...Separator lines and logos.
71102 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
71103 LINE(4:77)='***********************************************'//
71104 & '***************************'
71105 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
71106 LINE(6:37)=LOGO(ILIN-5)
71107 LINE(44:75)=LOGO(ILIN+14)
71108 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
71109 LINE(5:40)=REFER(2*ILIN-51)
71110 LINE(41:76)=REFER(2*ILIN-50)
71113 C...Write lines to appropriate unit.
71114 WRITE(MSTU(11),'(A79)') LINE
71120 C*********************************************************************
71123 C...Facilitates the updating of particle and decay data
71124 C...by allowing it to be done in an external file.
71126 SUBROUTINE PYUPDA(MUPDA,LFN)
71128 C...Double precision and integer declarations.
71129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71130 IMPLICIT INTEGER(I-N)
71131 INTEGER PYK,PYCHGE,PYCOMP
71133 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71134 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71135 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71136 COMMON/PYDAT4/CHAF(500,2)
71138 COMMON/PYINT4/MWID(500),WIDS(500,5)
71139 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
71140 C...Local arrays, character variables and data.
71141 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
71142 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
71143 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
71144 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
71145 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
71146 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
71147 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
71149 C...Write header if not yet done.
71150 IF(MSTU(12).NE.12345) CALL PYLIST(0)
71152 C...Write information on file for editing.
71153 IF(MUPDA.EQ.1) THEN
71155 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71156 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71157 & MWID(KC),MDCY(KC,1)
71158 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71159 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
71160 & (KFDP(IDC,J),J=1,5)
71164 C...Read complete set of information from edited file or
71165 C...read partial set of new or updated information from edited file.
71166 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
71168 C...Reset counters.
71172 IF(MUPDA.EQ.2) THEN
71177 DO 130 KC=1,MSTU(6)
71178 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
71179 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
71183 C...Begin of loop: read new line; unknown whether particle or
71185 140 READ(LFN,5200,END=190) CHINL
71187 C...Identify particle code and whether already defined (for MUPDA=3).
71188 IF(CHINL(2:10).NE.' ') THEN
71191 IF(MUPDA.EQ.2) THEN
71204 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
71207 C...Remove duplicate old decay data.
71208 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
71209 IDCREP=MDCY(KCREP,2)
71210 NDCREP=MDCY(KCREP,3)
71212 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
71214 DO 180 I=IDCREP,NDC-NDCREP
71215 MDME(I,1)=MDME(I+NDCREP,1)
71216 MDME(I,2)=MDME(I+NDCREP,2)
71217 BRAT(I)=BRAT(I+NDCREP)
71219 KFDP(I,J)=KFDP(I+NDCREP,J)
71224 ELSEIF(KCREP.NE.0) THEN
71232 C...Study line with particle data.
71233 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
71234 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
71235 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71236 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71237 & MWID(KC),MDCY(KC,1)
71241 C...Study line with decay data.
71244 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
71245 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
71246 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
71247 MDCY(KC,3)=MDCY(KC,3)+1
71248 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
71249 & (KFDP(NDC,J),J=1,5)
71252 C...End of loop; ensure that PYCOMP tables are updated.
71257 C...Perform possible tests that new information is consistent.
71258 DO 220 KC=1,MSTU(6)
71260 IF(KF.EQ.0) GOTO 220
71261 WRITE(CHKF,5300) KF
71262 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
71263 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
71264 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
71266 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71267 IF(MDME(IDC,2).GT.80) GOTO 210
71269 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
71273 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
71275 ELSEIF(PYCOMP(KP).EQ.0) THEN
71280 PMS=PMS-PMAS(KPC,1)
71281 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
71285 IF(KQ.NE.0) MERR=MAX(2,MERR)
71286 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
71288 IF(MERR.EQ.3) CALL PYERRM(17,
71289 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
71290 IF(MERR.EQ.2) CALL PYERRM(17,
71291 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
71292 IF(MERR.EQ.1) CALL PYERRM(7,
71293 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
71294 BRSUM=BRSUM+BRAT(IDC)
71296 WRITE(CHTMP,5500) BRSUM
71297 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
71298 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
71299 & CHTMP(9:16)//' for KF ='//CHKF)
71302 C...Write DATA statements for inclusion in program.
71303 ELSEIF(MUPDA.EQ.4) THEN
71305 C...Find out how many codes and decay channels are actually used.
71309 IF(KCHG(I,4).NE.0) THEN
71311 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
71315 C...Initialize writing of DATA statements for inclusion in program.
71318 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
71321 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
71325 C...Loop through variables for conversion to characters.
71327 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
71328 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
71329 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
71330 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
71331 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
71332 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
71333 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
71334 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
71335 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
71336 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
71337 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
71338 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
71339 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
71340 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
71341 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
71342 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
71343 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
71344 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
71345 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
71346 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
71347 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
71348 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
71350 C...Replace variables beyond what is properly defined.
71352 IF(IDIM.GT.KCC) CHTMP=' 0'
71353 ELSEIF(IVAR.LE.8) THEN
71354 IF(IDIM.GT.KCC) CHTMP=' 0.0'
71355 ELSEIF(IVAR.LE.11) THEN
71356 IF(IDIM.GT.KCC) CHTMP=' 0'
71357 ELSEIF(IVAR.LE.13) THEN
71358 IF(IDIM.GT.NDC) CHTMP=' 0'
71359 ELSEIF(IVAR.LE.14) THEN
71360 IF(IDIM.GT.NDC) CHTMP=' 0.0'
71361 ELSEIF(IVAR.LE.19) THEN
71362 IF(IDIM.GT.NDC) CHTMP=' 0'
71363 ELSEIF(IVAR.LE.21) THEN
71364 IF(IDIM.GT.KCC) CHTMP=' '
71366 IF(IDIM.GT.KCC) CHTMP=' 0'
71369 C...Length of variable, trailing decimal zeros, quotation marks.
71373 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
71374 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
71376 CHNEW=CHTMP(LLOW:LHIG)//' '
71378 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
71381 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
71382 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
71387 CHNEW(LNEW+1:LNEW+2)='D0'
71390 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
71391 DO 260 LL=LNEW,1,-1
71392 IF(CHNEW(LL:LL).EQ.'''') THEN
71394 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
71400 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
71404 C...Form composite character string, often including repetition counter.
71405 IF(CHNEW.NE.CHOLD) THEN
71412 IF(NRPT.GE.2) LRPT=LNEW+3
71413 IF(NRPT.GE.10) LRPT=LNEW+4
71414 IF(NRPT.GE.100) LRPT=LNEW+5
71415 IF(NRPT.GE.1000) LRPT=LNEW+6
71418 WRITE(CHTMP,5400) NRPT
71420 IF(NRPT.GE.10) LRPT=2
71421 IF(NRPT.GE.100) LRPT=3
71422 IF(NRPT.GE.1000) LRPT=4
71423 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
71427 C...Add characters to end of line, to new line (after storing old line),
71428 C...or to new block of lines (after writing old block).
71429 IF(LLIN+LCOM.LE.70) THEN
71430 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
71432 ELSEIF(NLIN.LE.19) THEN
71433 CHLIN(LLIN+1:72)=' '
71436 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
71439 CHLIN(LLIN:72)='/'//' '
71441 WRITE(CHTMP,5400) IDIM-NRPT
71442 CHBLK(1)(30:33)=CHTMP(13:16)
71444 WRITE(LFN,5700) CHBLK(ILIN)
71448 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
71449 & ',I= , )/'//CHCOM(1:LCOM)//','
71450 WRITE(CHTMP,5400) IDIM-NRPT+1
71451 CHLIN(25:28)=CHTMP(13:16)
71456 C...Write final block of lines.
71457 CHLIN(LLIN:72)='/'//' '
71459 WRITE(CHTMP,5400) NDIM
71460 CHBLK(1)(30:33)=CHTMP(13:16)
71462 WRITE(LFN,5700) CHBLK(ILIN)
71467 C...Formats for reading and writing particle data.
71468 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
71469 5100 FORMAT(10X,2I5,F12.6,5I10)
71480 C*********************************************************************
71483 C...Provides various integer-valued event related data.
71487 C...Double precision and integer declarations.
71488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71489 IMPLICIT INTEGER(I-N)
71490 INTEGER PYK,PYCHGE,PYCOMP
71492 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71495 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71497 C...Default value. For I=0 number of entries, number of stable entries
71498 C...or 3 times total charge.
71500 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71501 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
71503 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
71505 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
71506 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
71509 ELSEIF(I.EQ.0) THEN
71511 C...For I > 0 direct readout of K matrix or charge.
71512 ELSEIF(J.LE.5) THEN
71514 ELSEIF(J.EQ.6) THEN
71517 C...Status (existing/fragmented/decayed), parton/hadron separation.
71518 ELSEIF(J.LE.8) THEN
71519 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
71520 IF(J.EQ.8) PYK=PYK*K(I,2)
71521 ELSEIF(J.LE.12) THEN
71525 IF(KC.NE.0) KQ=KCHG(KC,2)
71526 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
71527 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
71529 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
71531 C...Heaviest flavour in hadron/diquark.
71532 ELSEIF(J.EQ.13) THEN
71534 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
71535 IF(KFA.LT.10) PYK=KFA
71536 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
71537 PYK=PYK*ISIGN(1,K(I,2))
71539 C...Particle history: generation, ancestor, rank.
71540 ELSEIF(J.LE.15) THEN
71547 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
71550 ELSEIF(J.EQ.16) THEN
71552 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
71553 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
71560 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
71561 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
71563 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
71564 IF(ILP.EQ.1) GOTO 120
71566 IF(K(I1,1).EQ.12) THEN
71568 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
71569 & .AND.K(I3,2).NE.93) PYK=PYK+1
71575 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
71579 C...Particle coming from collapsing jet system or not.
71580 ELSEIF(J.EQ.17) THEN
71587 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
71588 IF(PYK.EQ.1) PYK=-1
71592 IF(KCHG(KC,2).EQ.0) GOTO 150
71593 IF(K(I1,1).NE.12) PYK=0
71594 IF(K(I1,1).NE.12) RETURN
71597 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
71599 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
71601 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
71603 C...Number of decay products. Colour flow.
71604 ELSEIF(J.EQ.18) THEN
71605 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
71606 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
71607 ELSEIF(J.LE.22) THEN
71608 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
71609 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
71610 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
71611 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
71612 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
71619 C*********************************************************************
71622 C...Provides various real-valued event related data.
71626 C...Double precision and integer declarations.
71627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71628 IMPLICIT INTEGER(I-N)
71629 INTEGER PYK,PYCHGE,PYCOMP
71631 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71634 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71638 C...Set default value. For I = 0 sum of momenta or charges,
71639 C...or invariant mass of system.
71641 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71642 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
71644 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
71646 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
71650 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
71654 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71655 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
71657 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
71659 ELSEIF(I.EQ.0) THEN
71661 C...Direct readout of P matrix.
71662 ELSEIF(J.LE.5) THEN
71665 C...Charge, total momentum, transverse momentum, transverse mass.
71666 ELSEIF(J.LE.12) THEN
71667 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
71668 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
71669 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
71670 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
71671 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
71673 C...Theta and phi angle in radians or degrees.
71674 ELSEIF(J.LE.16) THEN
71675 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
71676 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
71677 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
71679 C...True rapidity, rapidity with pion mass, pseudorapidity.
71680 ELSEIF(J.LE.19) THEN
71682 IF(J.EQ.17) PMR=P(I,5)
71683 IF(J.EQ.18) PMR=PYMASS(211)
71684 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71685 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71688 C...Energy and momentum fractions (only to be used in CM frame).
71689 ELSEIF(J.LE.25) THEN
71690 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
71691 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
71692 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
71693 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
71694 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
71695 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
71701 C*********************************************************************
71704 C...Performs sphericity tensor analysis to give sphericity,
71705 C...aplanarity and the related event axes.
71707 SUBROUTINE PYSPHE(SPH,APL)
71709 C...Double precision and integer declarations.
71710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71711 IMPLICIT INTEGER(I-N)
71712 INTEGER PYK,PYCHGE,PYCOMP
71713 C...Parameter statement to help give large particle numbers.
71714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71715 &KEXCIT=4000000,KDIMEN=5000000)
71717 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71719 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71720 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71722 DIMENSION SM(3,3),SV(3,3)
71724 C...Calculate matrix to be diagonalized.
71733 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
71734 IF(MSTU(41).GE.2) THEN
71736 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71737 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71738 & K(I,2).EQ.KSUSY1+39) GOTO 140
71739 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71743 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71745 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
71746 & MAX(1D-10,PA)**(PARU(41)-2D0)
71749 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
71755 C...Very low multiplicities (0 or 1) not considered.
71757 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
71764 SM(J1,J2)=SM(J1,J2)/PS
71768 C...Find eigenvalues to matrix (third degree equation).
71769 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71770 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71771 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71772 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71773 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71774 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71775 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71776 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
71777 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
71778 IF(P(N+2,4).LT.1D-5) THEN
71779 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
71785 C...Find first and last eigenvector by solving equation system.
71788 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
71790 SV(J1,J2)=SM(J1,J2)
71791 SV(J2,J1)=SM(J1,J2)
71797 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
71800 SMAX=ABS(SV(J1,J2))
71804 DO 220 J3=JA+1,JA+2
71806 RL=SV(J1,JB)/SV(JA,JB)
71808 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
71809 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
71811 SMAX=ABS(SV(J1,J2))
71815 JB2=JB+2-3*((JB+1)/3)
71816 P(N+I,JB1)=-SV(JC,JB2)
71817 P(N+I,JB2)=SV(JC,JB1)
71818 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
71820 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
71821 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71823 P(N+I,J)=SGN*P(N+I,J)/PA
71827 C...Middle axis orthogonal to other two. Fill other codes.
71828 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71829 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
71830 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
71831 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
71844 C...Calculate sphericity and aplanarity. Select storing option.
71845 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
71849 IF(MSTU(43).LE.1) MSTU(3)=3
71850 IF(MSTU(43).GE.2) N=N+3
71855 C*********************************************************************
71858 C...Performs thrust analysis to give thrust, oblateness
71859 C...and the related event axes.
71861 SUBROUTINE PYTHRU(THR,OBL)
71863 C...Double precision and integer declarations.
71864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71865 IMPLICIT INTEGER(I-N)
71866 INTEGER PYK,PYCHGE,PYCOMP
71867 C...Parameter statement to help give large particle numbers.
71868 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71869 &KEXCIT=4000000,KDIMEN=5000000)
71871 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71874 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71876 DIMENSION TDI(3),TPR(3)
71878 C...Take copy of particles that are to be considered in thrust analysis.
71882 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
71883 IF(MSTU(41).GE.2) THEN
71885 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71886 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71887 & K(I,2).EQ.KSUSY1+39) GOTO 100
71888 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71891 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
71892 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
71902 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71904 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
71905 & P(N+NP,4)**(PARU(42)-1D0)
71906 PS=PS+P(N+NP,4)*P(N+NP,5)
71909 C...Very low multiplicities (0 or 1) not considered.
71911 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
71917 C...Loop over thrust and major. T axis along z direction in latter case.
71921 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
71923 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
71924 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
71925 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
71928 C...Find and order particles with highest p (pT for major).
71929 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
71933 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
71934 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
71935 IF(P(I,4).LE.P(ILF,4)) GOTO 140
71937 P(ILF+1,J)=P(ILF,J)
71946 C...Find and order initial axes with highest thrust (major).
71947 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
71950 NC=2**(MIN(MSTU(44),NP)-1)
71955 DO 200 ILF=1,MIN(MSTU(44),NP)
71956 SGN=P(N+NP+ILF+3,5)
71957 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
71959 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
71962 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
71963 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
71964 IF(TDS.LE.P(ILG,4)) GOTO 230
71966 P(ILG+1,J)=P(ILG,J)
71969 ILG=N+NP+MSTU(44)+4
71976 C...Iterate direction of axis until stable maximum.
71983 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
71984 IF(THP.GT.1D-10) TDI(J)=TPR(J)
71988 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
71990 TPR(J)=TPR(J)+SGN*P(I,J)
71993 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
71994 IF(THP.GE.THPS+PARU(48)) GOTO 270
71996 C...Save good axis. Try new initial axis until a number of tries agree.
71997 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
71998 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
72000 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72002 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
72008 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
72011 C...Find minor axis and value by orthogonality.
72012 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72013 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
72014 P(N+NP+3,2)=SGN*P(N+NP+2,1)
72018 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
72023 C...Fill axis information. Rotate back to original coordinate system.
72031 P(N+ILD,J)=P(N+NP+ILD,J)
72035 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
72037 C...Calculate thrust and oblateness. Select storing option.
72039 OBL=P(N+2,4)-P(N+3,4)
72042 IF(MSTU(43).LE.1) MSTU(3)=3
72043 IF(MSTU(43).GE.2) N=N+3
72048 C*********************************************************************
72051 C...Subdivides the particle content of an event into jets/clusters.
72053 SUBROUTINE PYCLUS(NJET)
72055 C...Double precision and integer declarations.
72056 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72057 IMPLICIT INTEGER(I-N)
72058 INTEGER PYK,PYCHGE,PYCOMP
72059 C...Parameter statement to help give large particle numbers.
72060 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72061 &KEXCIT=4000000,KDIMEN=5000000)
72063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72066 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72067 C...Local arrays and saved variables.
72069 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
72071 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
72072 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
72073 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
72074 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
72075 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72076 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
72077 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72079 C...If first time, reset. If reentering, skip preliminaries.
72080 IF(MSTU(48).LE.0) THEN
72086 PIMASS=PMAS(PYCOMP(211),1)
72089 IF(MSTU(43).GE.2) N=N-NJET
72090 DO 110 I=N+1,N+NJET
72091 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72093 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72096 R2ACC=PARU(45)*PS(5)**2
72102 C...Find which particles are to be considered in cluster search.
72104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
72105 IF(MSTU(41).GE.2) THEN
72107 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72108 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72109 & K(I,2).EQ.KSUSY1+39) GOTO 140
72110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72113 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
72114 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
72119 C...Take copy of these particles, with space left for jets later on.
72125 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72126 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72127 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72128 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72130 PS(J)=PS(J)+P(N+NP,J)
72140 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
72142 C...Very low multiplicities not considered.
72143 IF(NP.LT.MSTU(47)) THEN
72144 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
72149 C...Find precluster configuration. If too few jets, make harder cuts.
72151 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72154 R2ACC=PARU(45)*PS(5)**2
72156 RINIT=1.25D0*PARU(43)
72157 IF(NP.LE.MSTU(47)+2) RINIT=0D0
72158 170 RINIT=0.8D0*RINIT
72161 DO 180 I=N+NP+1,N+2*NP
72165 C...Sum up small momentum region. Jet if enough absolute momentum.
72166 IF(MSTU(46).LE.2) THEN
72170 DO 210 I=N+NP+1,N+2*NP
72171 IF(P(I,5).GT.2D0*RINIT) GOTO 210
72175 P(N+1,J)=P(N+1,J)+P(I,J)
72178 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
72179 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
72180 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72181 IF(NREM.EQ.0) GOTO 170
72184 C...Find fastest remaining particle.
72187 DO 230 I=N+NP+1,N+2*NP
72188 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
72193 P(N+NPRE,J)=P(IMAX,J)
72198 C...Sum up precluster around it according to pT separation.
72199 IF(MSTU(46).LE.2) THEN
72200 DO 260 I=N+NP+1,N+2*NP
72201 IF(K(I,4).NE.0) GOTO 260
72203 IF(R2.GT.RINIT**2) GOTO 260
72207 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
72210 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72212 C...Sum up precluster around it according to mass or
72213 C...Durham pT separation.
72217 DO 280 I=N+NP+1,N+2*NP
72218 IF(K(I,4).NE.0) GOTO 280
72219 IF(MSTU(46).LE.4) THEN
72224 IF(R2.GE.R2MIN) GOTO 280
72230 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
72232 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72239 C...Check if more preclusters to be found. Start over if too few.
72240 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72241 IF(NREM.GT.0) GOTO 220
72244 C...Reassign all particles to nearest jet. Sum up new jet momenta.
72247 310 IF(MSTU(46).LE.1) THEN
72248 DO 330 I=N+1,N+NJET
72253 DO 360 I=N+NP+1,N+2*NP
72255 DO 340 IJET=N+1,N+NJET
72256 IF(P(IJET,5).LT.RINIT) GOTO 340
72258 IF(R2.GE.R2MIN) GOTO 340
72264 V(IMIN,J)=V(IMIN,J)+P(I,J)
72268 DO 380 I=N+1,N+NJET
72272 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72277 C...Find two closest jets.
72278 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
72279 DO 400 ITRY1=N+1,N+NJET-1
72280 DO 390 ITRY2=ITRY1+1,N+NJET
72281 IF(MSTU(46).LE.2) THEN
72282 R2=R2T(ITRY1,ITRY2)
72283 ELSEIF(MSTU(46).LE.4) THEN
72284 R2=R2M(ITRY1,ITRY2)
72286 R2=R2D(ITRY1,ITRY2)
72288 IF(R2.GE.R2MIN) GOTO 390
72295 C...If allowed, join two closest jets and start over.
72296 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
72297 IREC=MIN(IMIN1,IMIN2)
72298 IDEL=MAX(IMIN1,IMIN2)
72300 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
72302 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
72303 DO 430 I=IDEL+1,N+NJET
72308 IF(MSTU(46).GE.2) THEN
72309 DO 440 I=N+NP+1,N+2*NP
72311 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
72312 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
72318 C...Divide up broad jet if empty cluster in list of final ones.
72319 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
72320 DO 450 I=N+1,N+NJET
72323 DO 460 I=N+NP+1,N+2*NP
72324 K(N+K(I,4),5)=K(N+K(I,4),5)+1
72327 DO 470 I=N+1,N+NJET
72328 IF(K(I,5).EQ.0) IEMP=I
72334 DO 480 I=N+NP+1,N+2*NP
72335 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
72338 IF(R2.LE.R2MAX) GOTO 480
72345 P(IEMP,J)=P(ISPL,J)
72346 P(IJET,J)=P(IJET,J)-P(ISPL,J)
72348 P(IEMP,5)=P(ISPL,5)
72349 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
72350 IF(NLOOP.LE.2) GOTO 300
72355 C...If generalized thrust has not yet converged, continue iteration.
72356 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
72362 C...Reorder jets according to energy.
72363 DO 510 I=N+1,N+NJET
72368 DO 540 INEW=N+1,N+NJET
72370 DO 520 ITRY=N+1,N+NJET
72371 IF(V(ITRY,4).LE.PEMAX) GOTO 520
72380 P(INEW,J)=V(IMAX,J)
72386 C...Clean up particle-jet assignments and jet information.
72387 DO 550 I=N+NP+1,N+2*NP
72390 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
72391 K(IORI,4)=K(IORI,4)+1
72395 DO 570 I=N+1,N+NJET
72398 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
72402 IF(K(I,4).EQ.0) IEMP=I
72405 C...Select storing option. Output variables. Check for failure.
72411 PARU(63)=SQRT(R2MIN)
72412 IF(NJET.LE.1) PARU(63)=0D0
72414 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
72418 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72419 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72425 C*********************************************************************
72428 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
72429 C...as used for calorimeters at hadron colliders.
72431 SUBROUTINE PYCELL(NJET)
72433 C...Double precision and integer declarations.
72434 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72435 IMPLICIT INTEGER(I-N)
72436 INTEGER PYK,PYCHGE,PYCOMP
72437 C...Parameter statement to help give large particle numbers.
72438 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72439 &KEXCIT=4000000,KDIMEN=5000000)
72441 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72443 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72444 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72446 C...Loop over all particles. Find cell that was hit by given particle.
72447 PTLRAT=1D0/SINH(PARU(51))**2
72451 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72452 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
72453 IF(MSTU(41).GE.2) THEN
72455 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72456 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72457 & K(I,2).EQ.KSUSY1+39) GOTO 110
72458 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72462 PT=SQRT(P(I,1)**2+P(I,2)**2)
72463 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
72464 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
72465 & (ETA/PARU(51)+1D0))))
72466 PHI=PYANGL(P(I,1),P(I,2))
72467 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
72468 & (PHI/PARU(1)+1D0))))
72469 IETPH=MSTU(52)*IETA+IPHI
72471 C...Add to cell already hit, or book new cell.
72473 IF(IETPH.EQ.K(IC,3)) THEN
72479 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
72480 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72488 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
72489 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
72493 C...Smear true bin content by calorimeter resolution.
72494 IF(MSTU(53).GE.1) THEN
72497 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
72498 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
72499 & COS(PARU(2)*PYR(0))
72500 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
72502 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
72506 C...Remove cells below threshold.
72507 IF(PARU(58).GT.0D0) THEN
72511 IF(P(IC,5).GT.PARU(58)) THEN
72523 C...Find initiator cell: the one with highest pT of not yet used ones.
72527 IF(K(IC,5).NE.2) GOTO 160
72528 IF(P(IC,5).LE.ETMAX) GOTO 160
72534 IF(ETMAX.LT.PARU(52)) GOTO 220
72535 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
72536 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72550 C...Sum up unused cells within required distance of initiator.
72552 IF(K(IC,5).EQ.0) GOTO 170
72553 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
72554 DPHIA=ABS(P(IC,2)-PHI)
72555 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
72557 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
72558 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
72560 K(NJ,4)=K(NJ,4)+K(IC,4)
72561 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
72562 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
72563 P(NJ,5)=P(NJ,5)+P(IC,5)
72566 C...Reject cluster below minimum ET, else accept.
72567 IF(P(NJ,5).LT.PARU(53)) THEN
72570 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
72572 ELSEIF(MSTU(54).LE.2) THEN
72573 P(NJ,3)=P(NJ,3)/P(NJ,5)
72574 P(NJ,4)=P(NJ,4)/P(NJ,5)
72575 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
72578 IF(K(IC,5).LT.0) K(IC,5)=0
72585 IF(K(IC,5).GE.0) GOTO 210
72586 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
72587 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
72588 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
72589 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
72595 C...Arrange clusters in falling ET sequence.
72596 220 DO 250 I=1,NJ-NC
72599 IF(K(IJ,5).EQ.0) GOTO 230
72600 IF(P(IJ,5).LT.ETMAX) GOTO 230
72608 K(N+I,4)=K(IJMAX,4)
72611 P(N+I,J)=P(IJMAX,J)
72617 C...Convert to massless or massive four-vectors.
72618 IF(MSTU(54).EQ.2) THEN
72619 DO 260 I=N+1,N+NJET
72621 P(I,1)=P(I,5)*COS(P(I,4))
72622 P(I,2)=P(I,5)*SIN(P(I,4))
72623 P(I,3)=P(I,5)*SINH(ETA)
72624 P(I,4)=P(I,5)*COSH(ETA)
72627 ELSEIF(MSTU(54).GE.3) THEN
72628 DO 270 I=N+1,N+NJET
72629 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
72633 C...Information about storage.
72637 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72638 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72643 C*********************************************************************
72646 C...Determines, approximately, the two jet masses that minimize
72647 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
72649 SUBROUTINE PYJMAS(PMH,PML)
72651 C...Double precision and integer declarations.
72652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72653 IMPLICIT INTEGER(I-N)
72654 INTEGER PYK,PYCHGE,PYCOMP
72655 C...Parameter statement to help give large particle numbers.
72656 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72657 &KEXCIT=4000000,KDIMEN=5000000)
72659 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72660 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72661 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72662 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72664 DIMENSION SM(3,3),SAX(3),PS(3,5)
72677 PIMASS=PMAS(PYCOMP(211),1)
72679 C...Take copy of particles that are to be considered in mass analysis.
72681 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
72682 IF(MSTU(41).GE.2) THEN
72684 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72685 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72686 & K(I,2).EQ.KSUSY1+39) GOTO 170
72687 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72690 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
72691 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
72700 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72701 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72702 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72704 C...Fill information in sphericity tensor and total momentum vector.
72707 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
72710 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72712 PS(3,J)=PS(3,J)+P(N+NP,J)
72716 C...Very low multiplicities (0 or 1) not considered.
72718 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
72723 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
72726 C...Find largest eigenvalue to matrix (third degree equation).
72729 SM(J1,J2)=SM(J1,J2)/PSS
72732 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
72733 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
72734 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
72735 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
72736 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
72737 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
72738 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
72740 C...Find largest eigenvector by solving equation system.
72742 SM(J1,J1)=SM(J1,J1)-SMA
72744 SM(J2,J1)=SM(J1,J2)
72750 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
72753 SMAX=ABS(SM(J1,J2))
72757 DO 250 J3=JA+1,JA+2
72759 RL=SM(J1,JB)/SM(JA,JB)
72761 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
72762 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
72764 SMAX=ABS(SM(J1,J2))
72768 JB2=JB+2-3*((JB+1)/3)
72769 SAX(JB1)=-SM(JC,JB2)
72770 SAX(JB2)=SM(JC,JB1)
72771 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
72773 C...Divide particles into two initial clusters by hemisphere.
72775 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
72777 IF(PSAX.LT.0D0) IS=2
72780 PS(IS,J)=PS(IS,J)+P(I,J)
72783 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
72784 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
72786 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
72790 PS(3,J)=PS(1,J)-PS(2,J)
72793 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)
72794 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
72795 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
72796 IF(PMDI.LT.PMD) THEN
72802 C...Loop back if significant reduction in sum of m^2.
72803 IF(PMD.LT.-PARU(48)*PMS) THEN
72807 PS(IS,J)=PS(IS,J)-P(IM,J)
72808 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
72814 C...Final masses and output.
72817 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
72818 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
72819 PMH=MAX(PS(1,5),PS(2,5))
72820 PML=MIN(PS(1,5),PS(2,5))
72825 C*********************************************************************
72828 C...Calculates the first few Fox-Wolfram moments.
72830 SUBROUTINE PYFOWO(H10,H20,H30,H40)
72832 C...Double precision and integer declarations.
72833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72834 IMPLICIT INTEGER(I-N)
72835 INTEGER PYK,PYCHGE,PYCOMP
72836 C...Parameter statement to help give large particle numbers.
72837 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72838 &KEXCIT=4000000,KDIMEN=5000000)
72840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72843 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72845 C...Copy momenta for particles and calculate H0.
72850 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72851 IF(MSTU(41).GE.2) THEN
72853 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72854 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72855 & K(I,2).EQ.KSUSY1+39) GOTO 110
72856 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72859 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
72860 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
72871 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72877 C...Very low multiplicities (0 or 1) not considered.
72879 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
72887 C...Calculate H1 - H4.
72893 DO 120 I2=I1+1,N+NP
72894 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72895 & (P(I1,4)*P(I2,4))
72896 H10=H10+P(I1,4)*P(I2,4)*CTHE
72897 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
72898 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
72899 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
72904 C...Calculate H1/H0 - H4/H0. Output.
72907 H10=(HD+2D0*H10)/H0
72908 H20=(HD+2D0*H20)/H0
72909 H30=(HD+2D0*H30)/H0
72910 H40=(HD+2D0*H40)/H0
72915 C*********************************************************************
72918 C...Evaluates various properties of an event, with statistics
72919 C...accumulated during the course of the run and
72920 C...printed at the end.
72922 SUBROUTINE PYTABU(MTABU)
72924 C...Double precision and integer declarations.
72925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72926 IMPLICIT INTEGER(I-N)
72927 INTEGER PYK,PYCHGE,PYCOMP
72928 C...Parameter statement to help give large particle numbers.
72929 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72930 &KEXCIT=4000000,KDIMEN=5000000)
72932 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72933 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72934 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72935 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
72936 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
72937 C...Local arrays, character variables, saved variables and data.
72938 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
72939 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
72940 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
72941 &KFDM(8),KFDC(200,0:8),NPDC(200)
72942 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
72943 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
72944 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
72945 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
72946 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
72947 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
72948 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
72949 &NEVDC/0/,NKFDC/0/,NREDC/0/
72951 C...Reset statistics on initial parton state.
72952 IF(MTABU.EQ.10) THEN
72956 C...Identify and order flavour content of initial state.
72957 ELSEIF(MTABU.EQ.11) THEN
72959 KFM1=2*IABS(MSTU(161))
72960 IF(MSTU(161).GT.0) KFM1=KFM1-1
72961 KFM2=2*IABS(MSTU(162))
72962 IF(MSTU(162).GT.0) KFM2=KFM2-1
72963 KFMN=MIN(KFM1,KFM2)
72964 KFMX=MAX(KFM1,KFM2)
72966 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
72969 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
72970 & KFMX.LT.KFIS(I,2))) THEN
72976 110 IF(IKFIS.LT.0) THEN
72979 IF(NKFIS.GE.100) RETURN
72980 DO 130 I=NKFIS,IKFIS,-1
72981 KFIS(I+1,1)=KFIS(I,1)
72982 KFIS(I+1,2)=KFIS(I,2)
72984 NPIS(I+1,J)=NPIS(I,J)
72994 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
72996 C...Count number of partons in initial state.
72999 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
73000 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
73001 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
73006 IF(IM.LE.0.OR.IM.GT.N) THEN
73008 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73010 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
73011 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
73021 IF(NP.GE.11) NPCO=8
73022 IF(NP.GE.16) NPCO=9
73023 IF(NP.GE.26) NPCO=10
73024 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
73027 C...Write statistics on initial parton state.
73028 ELSEIF(MTABU.EQ.12) THEN
73029 FAC=1D0/MAX(1,NEVIS)
73030 WRITE(MSTU(11),5000) NEVIS
73033 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73035 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73036 CALL PYNAME(KFM1,CHAU)
73038 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
73040 IF(KFIS(I,1).EQ.0) KFMX=0
73042 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73043 CALL PYNAME(KFM2,CHAU)
73045 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
73046 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
73047 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
73050 C...Copy statistics on initial parton state into /PYJETS/.
73051 ELSEIF(MTABU.EQ.13) THEN
73052 FAC=1D0/MAX(1,NEVIS)
73055 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73057 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73059 IF(KFIS(I,1).EQ.0) KFMX=0
73061 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73068 P(I,J)=FAC*NPIS(I,J)
73069 V(I,J)=FAC*NPIS(I,J+5)
73083 C...Reset statistics on number of particles/partons.
73084 ELSEIF(MTABU.EQ.20) THEN
73091 C...Identify whether particle/parton is primary or not.
73092 ELSEIF(MTABU.EQ.21) THEN
73096 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
73097 MSTU(62)=MSTU(62)+1
73100 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
73102 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
73104 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
73106 ELSEIF(KC.EQ.0) THEN
73107 ELSEIF(K(K(I,3),1).EQ.13) THEN
73109 IF(IM.LE.0.OR.IM.GT.N) THEN
73111 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73114 ELSEIF(KCHG(KC,2).EQ.0) THEN
73115 KCM=PYCOMP(K(K(I,3),2))
73117 IF(KCHG(KCM,2).NE.0) MPRI=1
73120 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
73121 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
73123 IF(K(I,1).LE.10) THEN
73125 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
73128 C...Fill statistics on number of particles/partons in event.
73130 KFS=3-ISIGN(1,K(I,2))-MPRI
73132 IF(KFA.EQ.KFFS(IP)) THEN
73135 ELSEIF(KFA.LT.KFFS(IP)) THEN
73141 220 IF(IKFFS.LT.0) THEN
73144 IF(NKFFS.GE.400) RETURN
73145 DO 240 IP=NKFFS,IKFFS,-1
73146 KFFS(IP+1)=KFFS(IP)
73148 NPFS(IP+1,J)=NPFS(IP,J)
73157 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
73160 C...Write statistics on particle/parton composition of events.
73161 ELSEIF(MTABU.EQ.22) THEN
73162 FAC=1D0/MAX(1,NEVFS)
73163 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
73165 CALL PYNAME(KFFS(I),CHAU)
73168 IF(KC.NE.0) MDCYF=MDCY(KC,1)
73169 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
73170 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
73173 C...Copy particle/parton composition information into /PYJETS/.
73174 ELSEIF(MTABU.EQ.23) THEN
73175 FAC=1D0/MAX(1,NEVFS)
73181 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
73183 P(I,J)=FAC*NPFS(I,J)
73203 C...Reset factorial moments statistics.
73204 ELSEIF(MTABU.EQ.30) THEN
73210 FM1FM(IM,IB,IP)=0D0
73211 FM2FM(IM,IB,IP)=0D0
73216 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
73217 ELSEIF(MTABU.EQ.31) THEN
73222 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
73223 IF(MSTU(41).GE.2) THEN
73225 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73226 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73227 & K(I,2).EQ.KSUSY1+39) GOTO 410
73228 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73229 & PYCHGE(K(I,2)).EQ.0) GOTO 410
73232 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73233 IF(MSTU(42).GE.2) PMR=P(I,5)
73234 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
73235 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
73237 IF(ABS(YETA).GT.PARU(57)) GOTO 410
73238 PHI=PYANGL(P(I,1),P(I,2))
73239 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
73240 IYETA=MAX(0,MIN(511,IYETA))
73241 IPHI=512D0*(PHI+PARU(1))/PARU(2)
73242 IPHI=MAX(0,MIN(511,IPHI))
73245 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
73248 C...Order particles in (pseudo)rapidity and/or azimuth.
73249 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73250 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73254 IF(NUPP.EQ.NLOW+1) THEN
73259 DO 350 I1=NUPP-1,NLOW+1,-1
73260 IF(IYETA.GE.K(I1,1)) GOTO 360
73263 360 K(I1+1,1)=IYETA
73264 DO 370 I1=NUPP-1,NLOW+1,-1
73265 IF(IPHI.GE.K(I1,2)) GOTO 380
73269 DO 390 I1=NUPP-1,NLOW+1,-1
73270 IF(IYEP.GE.K(I1,3)) GOTO 400
73280 C...Calculate sum of factorial moments in event.
73288 IF(IM.LE.2) IBIN=2**(10-IB)
73289 IF(IM.EQ.3) IBIN=4**(10-IB)
73290 IAGR=K(NLOW+1,IM)/IBIN
73292 DO 440 I=NLOW+2,NUPP+1
73294 IF(ICUT.EQ.IAGR) THEN
73298 ELSEIF(NAGR.EQ.2) THEN
73299 FEVFM(IB,1)=FEVFM(IB,1)+2D0
73300 ELSEIF(NAGR.EQ.3) THEN
73301 FEVFM(IB,1)=FEVFM(IB,1)+6D0
73302 FEVFM(IB,2)=FEVFM(IB,2)+6D0
73303 ELSEIF(NAGR.EQ.4) THEN
73304 FEVFM(IB,1)=FEVFM(IB,1)+12D0
73305 FEVFM(IB,2)=FEVFM(IB,2)+24D0
73306 FEVFM(IB,3)=FEVFM(IB,3)+24D0
73308 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
73309 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
73310 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73312 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73313 & (NAGR-3D0)*(NAGR-4D0)
73321 C...Add results to total statistics.
73324 IF(FEVFM(1,IP).LT.0.5D0) THEN
73326 ELSEIF(IM.LE.2) THEN
73327 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73329 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73331 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
73332 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
73336 NMUFM=NMUFM+(NUPP-NLOW)
73339 C...Write accumulated statistics on factorial moments.
73340 ELSEIF(MTABU.EQ.32) THEN
73341 FAC=1D0/MAX(1,NEVFM)
73342 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
73343 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
73344 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
73346 WRITE(MSTU(11),5500)
73349 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
73351 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
73352 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
73353 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
73355 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
73356 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73359 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
73364 C...Copy statistics on factorial moments into /PYJETS/.
73365 ELSEIF(MTABU.EQ.33) THEN
73366 FAC=1D0/MAX(1,NEVFM)
73373 IF(IM.NE.2) K(I,3)=2**(IB-1)
73375 IF(IM.NE.1) K(I,4)=2**(IB-1)
73377 P(I,1)=2D0*PARU(57)/K(I,3)
73378 V(I,1)=PARU(2)/K(I,4)
73380 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
73381 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73397 C...Reset statistics on Energy-Energy Correlation.
73398 ELSEIF(MTABU.EQ.40) THEN
73409 C...Find particles to include, with proper assumed mass.
73410 ELSEIF(MTABU.EQ.41) THEN
73416 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
73417 IF(MSTU(41).GE.2) THEN
73419 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73420 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73421 & K(I,2).EQ.KSUSY1+39) GOTO 570
73422 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73423 & PYCHGE(K(I,2)).EQ.0) GOTO 570
73426 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73427 IF(MSTU(42).GE.2) PMR=P(I,5)
73428 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73429 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73436 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73437 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
73440 IF(NUPP.EQ.NLOW) RETURN
73442 C...Analyze Energy-Energy Correlation in event.
73443 FAC=(2D0/ECM**2)*50D0/PARU(1)
73447 DO 600 I1=NLOW+2,NUPP
73448 DO 590 I2=NLOW+1,I1-1
73449 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
73450 & (P(I1,5)*P(I2,5))
73451 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
73452 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
73453 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
73457 FE1EC(J)=FE1EC(J)+FEVEE(J)
73458 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
73459 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
73460 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
73461 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
73462 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
73466 C...Write statistics on Energy-Energy Correlation.
73467 ELSEIF(MTABU.EQ.42) THEN
73468 FAC=1D0/MAX(1,NEVEE)
73469 WRITE(MSTU(11),5700) NEVEE
73472 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
73473 FEEC2=FAC*FE1EC(51-J)
73474 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
73476 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
73477 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
73478 & FEEC2,FEES2,FEECA,FEESA
73481 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
73482 ELSEIF(MTABU.EQ.43) THEN
73483 FAC=1D0/MAX(1,NEVEE)
73490 P(I,1)=FAC*FE1EC(I)
73491 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
73492 P(I,2)=FAC*FE1EC(51-I)
73493 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
73494 P(I,3)=FAC*FE1EA(I)
73495 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
73496 P(I,4)=PARU(1)*(I-1)/50D0
73497 P(I,5)=PARU(1)*I/50D0
73512 C...Reset statistics on decay channels.
73513 ELSEIF(MTABU.EQ.50) THEN
73518 C...Identify and order flavour content of final state.
73519 ELSEIF(MTABU.EQ.51) THEN
73523 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
73530 IF(K(I,2).LT.0) KFM=KFM-1
73531 DO 650 IDS=NDS-1,1,-1
73533 IF(KFM.LT.KFDM(IDS)) GOTO 660
73534 KFDM(IDS+1)=KFDM(IDS)
73540 C...Find whether old or new final state.
73542 IF(NDS.LT.KFDC(IDC,0)) THEN
73545 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
73547 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
73550 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
73559 700 IF(IKFDC.LT.0) THEN
73561 ELSEIF(NKFDC.GE.200) THEN
73565 DO 720 IDC=NKFDC,IKFDC,-1
73566 NPDC(IDC+1)=NPDC(IDC)
73568 KFDC(IDC+1,I)=KFDC(IDC,I)
73574 KFDC(IKFDC,I)=KFDM(I)
73578 NPDC(IKFDC)=NPDC(IKFDC)+1
73580 C...Write statistics on decay channels.
73581 ELSEIF(MTABU.EQ.52) THEN
73582 FAC=1D0/MAX(1,NEVDC)
73583 WRITE(MSTU(11),5900) NEVDC
73585 DO 740 I=1,KFDC(IDC,0)
73588 IF(2*KF.NE.KFM) KF=-KF
73589 CALL PYNAME(KF,CHAU)
73591 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
73593 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
73595 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
73597 C...Copy statistics on decay channels into /PYJETS/.
73598 ELSEIF(MTABU.EQ.53) THEN
73599 FAC=1D0/MAX(1,NEVDC)
73605 K(IDC,5)=KFDC(IDC,0)
73610 DO 770 I=1,KFDC(IDC,0)
73613 IF(2*KF.NE.KFM) KF=-KF
73614 IF(I.LE.5) P(IDC,I)=KF
73615 IF(I.GE.6) V(IDC,I-5)=KF
73617 V(IDC,5)=FAC*NPDC(IDC)
73632 C...Format statements for output on unit MSTU(11) (default 6).
73633 5000 FORMAT(///20X,'Event statistics - initial state'/
73634 &20X,'based on an analysis of ',I6,' events'//
73635 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
73636 &'according to fragmenting system multiplicity'/
73637 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
73638 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
73639 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
73640 5200 FORMAT(///20X,'Event statistics - final state'/
73641 &20X,'based on an analysis of ',I7,' events'//
73642 &5X,'Mean primary multiplicity =',F10.4/
73643 &5X,'Mean final multiplicity =',F10.4/
73644 &5X,'Mean charged multiplicity =',F10.4//
73645 &5X,'Number of particles produced per event (directly and via ',
73646 &'decays/branchings)'/
73647 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
73648 &8X,'Total'/35X,'prim seco prim seco'/)
73649 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
73650 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
73651 &20X,'based on an analysis of ',I6,' events'//
73652 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
73653 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
73655 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
73656 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
73657 &20X,'based on an analysis of ',I6,' events'//
73658 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
73659 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
73660 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
73661 5900 FORMAT(///20X,'Decay channel analysis - final state'/
73662 &20X,'based on an analysis of ',I6,' events'//
73663 &2X,'Probability',10X,'Complete final state'/)
73664 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
73665 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
73666 &'or table overflow)')
73671 C*********************************************************************
73674 C...Handles the generation of an e+e- annihilation jet event.
73676 SUBROUTINE PYEEVT(KFL,ECM)
73678 C...Double precision and integer declarations.
73679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73680 IMPLICIT INTEGER(I-N)
73681 INTEGER PYK,PYCHGE,PYCOMP
73683 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73686 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73688 C...Check input parameters.
73689 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73690 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73691 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
73692 IF(MSTU(21).GE.1) RETURN
73694 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
73695 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
73696 IF(ECM.LT.ECMMIN) THEN
73697 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
73698 IF(MSTU(21).GE.1) RETURN
73701 C...Check consistency of MSTJ options set.
73702 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
73704 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
73707 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
73709 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
73713 C...Initialize alpha_strong and total cross-section.
73714 MSTU(111)=MSTJ(108)
73715 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73717 PARU(112)=PARJ(121)
73718 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73719 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
73720 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
73722 IF(MSTJ(116).GE.3) MSTJ(116)=1
73725 C...Add initial e+e- to event record (documentation only).
73728 IF(NTRY.GT.100) THEN
73729 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
73734 IF(MSTJ(115).GE.2) THEN
73736 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73738 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73742 C...Radiative photon (in initial state).
73745 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
73747 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
73748 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
73750 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
73751 K(NC,3)=MIN(MSTJ(115)/2,1)
73754 C...Virtual exchange boson (gamma or Z0).
73755 IF(MSTJ(115).GE.3) THEN
73758 IF(MSTJ(102).EQ.2) KF=23
73762 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
73768 C...Choice of flavour and jet configuration.
73769 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
73770 IF(KFLC.EQ.0) GOTO 100
73771 CALL PYXJET(ECMC,NJET,CUT)
73773 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
73775 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
73776 IF(NJET.EQ.2) MSTJ(120)=1
73778 C...Fill jet configuration and origin.
73779 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
73780 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
73782 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
73783 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
73784 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73785 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
73786 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73787 IF(MSTU(24).NE.0) GOTO 100
73789 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
73792 C...Angular orientation according to matrix element.
73793 IF(MSTJ(106).EQ.1) THEN
73794 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
73795 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73796 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73799 C...Rotation and boost from radiative photon.
73801 DBEK=-PAK/(ECM-PAK)
73802 NMIN=NC+1-MSTJ(115)/3
73803 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
73804 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
73805 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
73808 C...Generate parton shower. Rearrange along strings and check.
73809 IF(MSTJ(101).EQ.5) THEN
73810 CALL PYSHOW(N-1,N,ECMC)
73812 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73813 IF(MSTJ(105).GE.0) MSTU(28)=0
73816 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73819 C...Fragmentation/decay generation. Information for PYTABU.
73820 IF(MSTJ(105).EQ.1) CALL PYEXEC
73827 C*********************************************************************
73830 C...Calculates total cross-section, including initial state
73831 C...radiation effects.
73833 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
73835 C...Double precision and integer declarations.
73836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73837 IMPLICIT INTEGER(I-N)
73838 INTEGER PYK,PYCHGE,PYCOMP
73840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73842 SAVE /PYDAT1/,/PYDAT2/
73844 C...Status, (optimized) Q^2 scale, alpha_strong.
73846 MSTJ(119)=10*MSTJ(102)+KFL
73847 IF(MSTJ(111).EQ.0) THEN
73849 ELSEIF(MSTU(111).EQ.0) THEN
73850 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
73851 & ((33D0-2D0*MSTU(112))*PARU(111)))))
73852 Q2R=PARJ(168)*ECM**2
73854 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
73855 & (2D0*PARU(112)/ECM)**2))
73856 Q2R=PARJ(168)*ECM**2
73858 ALSPI=PYALPS(Q2R)/PARU(1)
73860 C...QCD corrections factor in R.
73861 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
73863 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
73865 ELSEIF(MSTJ(109).EQ.0) THEN
73866 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
73867 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
73868 & LOG(PARJ(168))*ALSPI**2)
73869 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
73870 RQCD=1D0+(3D0/4D0)*ALSPI
73872 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
73875 C...Calculate Z0 width if default value not acceptable.
73876 IF(MSTJ(102).GE.3) THEN
73877 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
73878 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
73881 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
73882 & (2D0*PYMASS(KFLC)/ ECM)**2))
73883 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
73884 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
73885 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
73887 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
73891 C...Calculate propagator and related constants for QFD case.
73892 POLL=1D0-PARJ(131)*PARJ(132)
73893 IF(MSTJ(102).GE.2) THEN
73894 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73895 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73896 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73897 VE=4D0*PARU(102)-1D0
73898 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
73899 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
73904 C...Loop over different flavours: charge, velocity.
73909 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
73910 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
73913 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
73914 QF=KCHG(KFLC,1)/3D0
73916 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
73918 C...Calculate R and sum of charges for QED or QFD case.
73919 RQQ=RQQ+3D0*QF**2*POLL
73920 IF(MSTJ(102).LE.1) THEN
73921 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
73923 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
73924 RQV=RQV-6D0*QF*VF*SF1I
73925 RVA=RVA+3D0*(VF**2+1D0)*SF1W
73926 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
73927 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
73931 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
73933 C...Calculate cross-section, including QCD corrections.
73936 PARJ(143)=RTOT*RQCD
73937 PARJ(144)=PARJ(143)
73938 PARJ(145)=PARJ(141)*86.8D0/ECM**2
73939 PARJ(146)=PARJ(142)*86.8D0/ECM**2
73940 PARJ(147)=PARJ(143)*86.8D0/ECM**2
73941 PARJ(148)=PARJ(147)
73942 PARJ(157)=RSUM*RQCD
73946 IF(MSTJ(107).LE.0) RETURN
73948 C...Virtual cross-section.
73950 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
73951 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
73952 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
73953 &1.526D0*LOG(ECM**2/0.932D0)
73955 C...Soft and hard radiative cross-section in QED case.
73956 IF(MSTJ(102).LE.1) THEN
73957 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
73958 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
73959 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
73961 C...Soft and hard radiative cross-section in QFD case.
73963 SZM=1D0-(PARJ(123)/ECM)**2
73964 SZW=PARJ(123)*PARJ(124)/ECM**2
73965 PARJ(161)=-RQQ/RSUM
73966 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
73967 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
73968 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
73969 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
73970 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
73971 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
73972 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
73973 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
73974 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
73975 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
73976 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
73977 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
73978 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
73981 C...Total cross-section and fraction of hard photon events.
73982 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
73983 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
73984 PARJ(144)=PARJ(157)
73985 PARJ(148)=PARJ(144)*86.8D0/ECM**2
73991 C*********************************************************************
73994 C...Generates initial state photon radiation.
73996 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
73998 C...Double precision and integer declarations.
73999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74000 IMPLICIT INTEGER(I-N)
74001 INTEGER PYK,PYCHGE,PYCOMP
74003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74006 C...Function: cumulative hard photon spectrum in QFD case.
74007 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
74008 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
74010 C...Determine whether radiative photon or not.
74013 IF(PARJ(160).LT.PYR(0)) RETURN
74016 C...Photon energy range. Find photon momentum in QED case.
74018 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
74019 IF(MSTJ(102).LE.1) THEN
74020 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
74021 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
74023 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
74025 SZM=1D0-(PARJ(123)/ECM)**2
74026 SZW=PARJ(123)*PARJ(124)/ECM**2
74029 FXKD=1D-4*(FXKU-FXKL)
74030 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
74035 IF(FXKV.GT.FXKR) THEN
74042 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
74043 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
74047 C...Photon polar and azimuthal angle.
74048 PME=2D0*(PYMASS(11)/ECM)**2
74049 120 CTHM=PME*(2D0/PME)**PYR(0)
74050 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
74051 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
74053 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
74054 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
74055 THEK=PYANGL(CTHE,STHE)
74056 PHIK=PARU(2)*PYR(0)
74058 C...Rotation angle for hadronic system.
74060 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
74062 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
74063 &(2D0-XK*(1D0-SGN*CTHE)))
74068 C*********************************************************************
74071 C...Selects flavour for produced qqbar pair.
74073 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
74075 C...Double precision and integer declarations.
74076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74077 IMPLICIT INTEGER(I-N)
74078 INTEGER PYK,PYCHGE,PYCOMP
74080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74081 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74082 SAVE /PYDAT1/,/PYDAT2/
74084 C...Calculate maximum weight in QED or QFD case.
74085 IF(MSTJ(102).LE.1) THEN
74088 POLL=1D0-PARJ(131)*PARJ(132)
74089 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74090 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74091 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
74092 VE=4D0*PARU(102)-1D0
74093 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
74094 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
74095 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
74096 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
74097 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
74101 C...Choose flavour. Gives charge and velocity.
74104 IF(NTRY.GT.100) THEN
74105 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
74110 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
74113 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
74114 QF=KCHG(KFLC,1)/3D0
74116 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
74118 C...Calculate weight in QED or QFD case.
74119 IF(MSTJ(102).LE.1) THEN
74121 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
74123 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
74124 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
74125 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
74127 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
74130 C...Weighting or new event (radiative photon). Cross-section update.
74131 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
74132 PARJ(158)=PARJ(158)+1D0
74133 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
74134 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
74135 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
74136 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
74137 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74142 C*********************************************************************
74145 C...Selects number of jets in matrix element approach.
74147 SUBROUTINE PYXJET(ECM,NJET,CUT)
74149 C...Double precision and integer declarations.
74150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74151 IMPLICIT INTEGER(I-N)
74152 INTEGER PYK,PYCHGE,PYCOMP
74154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74156 C...Local array and data.
74158 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
74160 C...Trivial result for two-jets only, including parton shower.
74161 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74164 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
74165 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
74167 IF(MSTJ(109).EQ.2) CF=1D0
74168 IF(MSTJ(111).EQ.0) THEN
74171 ELSEIF(MSTU(111).EQ.0) THEN
74172 PARJ(169)=MIN(1D0,PARJ(129))
74173 Q2=PARJ(169)*ECM**2
74174 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
74175 & ((33D0-2D0*MSTU(112))*PARU(111)))))
74176 Q2R=PARJ(168)*ECM**2
74178 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
74179 Q2=PARJ(169)*ECM**2
74180 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
74181 & (2D0*PARU(112)/ECM)**2))
74182 Q2R=PARJ(168)*ECM**2
74185 C...alpha_strong for R and R itself.
74186 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
74187 IF(IABS(MSTJ(101)).EQ.1) THEN
74189 ELSEIF(MSTJ(109).EQ.0) THEN
74190 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
74191 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
74192 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
74194 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
74197 C...alpha_strong for jet rate. Initial value for y cut.
74198 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74199 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
74200 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
74201 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
74202 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74204 C...Parametrization of first order three-jet cross-section.
74205 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
74208 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
74209 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
74210 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
74211 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
74212 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
74216 C...Parametrization of second order three-jet cross-section.
74217 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
74218 & CUT.GE.0.25D0) THEN
74220 ELSEIF(MSTJ(110).LE.1) THEN
74221 CT=LOG(1D0/CUT-2D0)
74222 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
74223 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
74225 C...Interpolation in second/first order ratio for Zhu parametrization.
74226 ELSEIF(MSTJ(110).EQ.2) THEN
74229 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74235 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
74237 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
74240 C...Shift in second order three-jet cross-section with optimized Q^2.
74241 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
74242 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
74243 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
74245 C...Parametrization of second order four-jet cross-section.
74246 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
74249 CT=LOG(1D0/CUT-5D0)
74250 IF(CUT.LE.0.018D0) THEN
74251 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
74252 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
74254 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
74255 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74257 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
74258 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
74259 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
74260 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
74261 & 0.002093D0*CT**3)
74262 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74264 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
74265 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
74268 C...If negative three-jet rate, change y' optimization parameter.
74269 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
74270 & PARJ(169).LT.0.99D0) THEN
74271 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74272 Q2=PARJ(169)*ECM**2
74273 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74277 C...If too high cross-section, use harder cuts, or fail.
74278 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
74279 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
74280 & PARJ(169).LT.0.99D0) THEN
74281 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74282 Q2=PARJ(169)*ECM**2
74283 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74285 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
74287 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
74289 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
74290 & PARJ(154))**(-1D0/3D0)
74291 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74295 C...Scalar gluon (first order only).
74297 ALSPI=PYALPS(ECM**2)/PARU(1)
74298 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
74300 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
74301 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
74306 C...Select number of jets.
74308 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74310 ELSEIF(MSTJ(101).LE.0) THEN
74311 NJET=MIN(4,2-MSTJ(101))
74315 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
74316 IF(PARJ(154).GT.RNJ) NJET=4
74322 C*********************************************************************
74325 C...Selects the kinematical variables of three-jet events.
74327 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
74329 C...Double precision and integer declarations.
74330 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74331 IMPLICIT INTEGER(I-N)
74332 INTEGER PYK,PYCHGE,PYCOMP
74334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74337 DIMENSION ZHUP(5,12)
74339 C...Coefficients of Zhu second order parametrization.
74340 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
74341 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
74342 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
74343 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
74344 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
74345 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
74346 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
74347 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
74348 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
74349 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
74350 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
74352 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
74353 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
74356 C...Event type. Mass effect factors and other common constants.
74360 QME=(2D0*PMQ/ECM)**2
74361 IF(MSTJ(109).NE.1) THEN
74363 CUTD=LOG(1D0/CUT-2D0)
74364 IF(MSTJ(109).EQ.0) THEN
74368 WTMX=MIN(20D0,37D0-6D0*CUTD)
74369 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
74377 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
74378 ALS2PI=PARU(118)/PARU(2)
74380 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
74381 & LOG(PARJ(169))*ALS2PI
74382 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
74384 C...Choose three-jet events in allowed region.
74386 110 Y13L=CUTL+CUTD*PYR(0)
74387 Y23L=CUTL+CUTD*PYR(0)
74391 IF(Y12.LE.CUT) GOTO 110
74392 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
74394 C...Second order corrections.
74395 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
74400 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
74401 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
74402 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
74403 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
74404 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
74405 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
74406 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
74407 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
74408 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
74409 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
74410 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
74411 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
74412 & TR*(2D0*CUTL/3D0-10D0/9D0)+
74413 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
74414 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
74415 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
74416 & Y13*Y23)/(Y12+Y13)**2)/WT1+
74417 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
74418 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
74419 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
74420 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
74421 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
74422 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
74423 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
74424 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74425 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74426 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
74428 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
74429 C...Second order corrections; Zhu parametrization of ERT.
74434 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74438 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74439 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74440 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74441 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74444 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74445 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74446 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74447 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74449 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74450 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74451 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74452 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74453 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
74455 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74456 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74457 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
74460 C...Impose mass cuts (gives two jets). For fixed jet number new try.
74464 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
74465 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
74466 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
74467 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
74468 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
74470 C...Scalar gluon model (first order only, no mass effects).
74473 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
74474 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
74475 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
74476 X1=1D0-0.5D0*(X3+YD)
74477 X2=1D0-0.5D0*(X3-YD)
74478 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
74479 IF(MSTJ(102).GE.2) THEN
74480 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
74481 & X3**2*PYR(0)) NJET=2
74483 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
74489 C*********************************************************************
74492 C...Selects the kinematical variables of four-jet events.
74494 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
74496 C...Double precision and integer declarations.
74497 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74498 IMPLICIT INTEGER(I-N)
74499 INTEGER PYK,PYCHGE,PYCOMP
74501 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74504 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
74506 C...Common constants. Colour factors for QCD and Abelian gluon theory.
74508 QME=(2D0*PMQ/ECM)**2
74509 CT=LOG(1D0/CUT-5D0)
74510 IF(MSTJ(109).EQ.0) THEN
74520 C...Choice of process (qqbargg or qqbarqqbar).
74523 IF(PARJ(155).GT.PYR(0)) IT=2
74524 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
74525 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
74526 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
74527 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
74530 C...Sample the five kinematical variables (for qqgg preweighted in y34).
74531 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74532 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74533 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
74534 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
74535 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
74537 CP=COS(PARU(1)*PYR(0))
74540 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
74541 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
74542 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
74544 Y12=1D0-Y134-Y23-Y24
74545 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
74549 C...Calculate matrix elements for qqgg or qqqq process.
74554 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
74555 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
74556 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
74557 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
74558 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
74559 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
74560 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
74561 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
74562 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
74563 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
74564 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
74565 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
74566 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
74567 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
74568 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
74569 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
74570 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
74571 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
74572 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
74573 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
74574 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
74575 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
74576 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
74577 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
74578 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
74579 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
74580 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
74581 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
74582 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
74583 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
74584 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
74585 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
74586 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
74587 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
74588 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
74589 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
74590 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
74591 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
74592 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
74593 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
74594 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
74597 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
74598 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
74599 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
74600 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
74601 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
74602 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
74603 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
74604 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
74605 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
74606 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
74607 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
74608 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
74609 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
74610 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
74611 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
74612 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
74613 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
74614 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
74617 C...Permutations of momenta in matrix element. Weighting.
74618 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
74629 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
74640 IF(IC.LE.3) GOTO 120
74641 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
74644 C...qqgg events: string configuration and event type.
74646 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
74647 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
74648 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
74649 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
74650 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
74651 IF(ID.EQ.2) GOTO 130
74652 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
74653 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
74654 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
74655 IF(ID.EQ.2) GOTO 130
74658 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
74659 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
74662 C...Mass cuts. Kinematical variables out.
74663 IF(Y12.LE.CUT+QME) NJET=2
74664 IF(NJET.EQ.2) GOTO 150
74665 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
74666 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
74667 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
74669 X12=(1D0-Q12)*Y13+Q12*Y23
74671 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74673 C...qqbarqqbar events: string configuration, choose new flavour.
74676 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
74677 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
74678 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
74679 IF(WTR.LT.WTD(4)) ID=4
74680 IF(ID.GE.2) GOTO 130
74683 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
74684 140 KFLN=1+INT(5D0*PYR(0))
74685 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
74686 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
74687 IF(KFLN.GT.MSTJ(104)) NJET=2
74689 QMEN=(2D0*PMQN/ECM)**2
74691 C...Mass cuts. Kinematical variables out.
74692 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
74693 IF(NJET.EQ.2) GOTO 150
74694 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
74695 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
74696 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
74697 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
74698 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
74699 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
74702 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
74704 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
74705 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
74706 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74708 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
74713 C*********************************************************************
74716 C...Gives the angular orientation of events.
74718 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
74720 C...Double precision and integer declarations.
74721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74722 IMPLICIT INTEGER(I-N)
74723 INTEGER PYK,PYCHGE,PYCOMP
74725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74728 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74730 C...Charge. Factors depending on polarization for QED case.
74732 POLL=1D0-PARJ(131)*PARJ(132)
74733 POLD=PARJ(132)-PARJ(131)
74734 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
74740 C...Factors depending on flavour, energy and polarization for QFD case.
74742 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74743 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74744 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
74746 VE=4D0*PARU(102)-1D0
74748 VF=AF-4D0*QF*PARU(102)
74749 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
74750 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
74751 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
74752 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
74753 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
74754 & SFW*SFF**2*(VE**2-AE**2))
74755 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
74759 C...Mass factor. Differential cross-sections for two-jet events.
74762 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
74763 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
74765 SIGU=4D0*SQRT(1D0-QME)
74766 SIGL=2D0*QME*SQRT(1D0-QME)
74772 C...Kinematical variables. Reduce four-jet event to three-jet one.
74775 X1=2D0*P(NC+1,4)/ECM
74776 X2=2D0*P(NC+3,4)/ECM
74778 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
74779 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
74780 X1=2D0*P(NC+1,4)/ECMR
74781 X2=2D0*P(NC+4,4)/ECMR
74784 C...Differential cross-sections for three-jet (or reduced four-jet).
74785 XQ=(1D0-X1)/(1D0-X2)
74786 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
74787 ST12=SQRT(1D0-CT12**2)
74788 IF(MSTJ(109).NE.1) THEN
74789 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
74790 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
74791 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
74792 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
74794 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
74795 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
74796 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
74797 SIGA=X2**2*ST12/SQ2
74798 SIGP=2D0*(X1**2-X2**2*CT12)
74800 C...Differential cross-sect for scalar gluons (no mass effects).
74804 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
74805 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
74806 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
74807 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
74808 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
74809 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
74810 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
74811 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
74812 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
74813 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
74814 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
74818 C...Upper bounds for differential cross-section.
74823 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
74824 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
74825 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
74826 &2D0*HF2A*ABS(SIGP)
74828 C...Generate angular orientation according to differential cross-sect.
74829 100 CHI=PARU(2)*PYR(0)
74830 CTHE=2D0*PYR(0)-1D0
74838 C2PHI=COS(2D0*(PHI-PARJ(134)))
74839 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74840 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
74841 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
74842 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
74843 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
74844 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
74845 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
74846 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
74847 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
74852 C*********************************************************************
74855 C...Generates Upsilon and toponium decays into three gluons
74856 C...or two gluons and a photon.
74858 SUBROUTINE PYONIA(KFL,ECM)
74860 C...Double precision and integer declarations.
74861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74862 IMPLICIT INTEGER(I-N)
74863 INTEGER PYK,PYCHGE,PYCOMP
74865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74868 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74870 C...Printout. Check input parameters.
74871 IF(MSTU(12).NE.12345) CALL PYLIST(0)
74872 IF(KFL.LT.0.OR.KFL.GT.8) THEN
74873 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
74874 IF(MSTU(21).GE.1) RETURN
74876 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
74877 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
74878 IF(MSTU(21).GE.1) RETURN
74881 C...Initial e+e- and onium state (optional).
74883 IF(MSTJ(115).GE.2) THEN
74885 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
74887 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
74891 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
74897 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
74903 C...Choose x1 and x2 according to matrix element.
74908 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
74909 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
74912 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
74913 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
74915 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
74916 MSTU(111)=MSTJ(108)
74917 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
74919 PARU(112)=PARJ(121)
74920 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
74922 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
74923 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
74926 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
74927 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
74929 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
74930 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
74933 ECMC=SQRT(1D0-X1)*ECM
74934 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
74939 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
74940 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
74941 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
74942 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
74944 IF(ECMC.LT.4D0*PARJ(127)) THEN
74948 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
74954 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
74957 C...Differential cross-sections. Upper limit for cross-section.
74958 IF(MSTJ(106).EQ.1) THEN
74960 HF1=1D0-PARJ(131)*PARJ(132)
74962 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
74963 ST13=SQRT(1D0-CT13**2)
74964 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
74965 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
74967 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
74968 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
74969 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
74971 C...Angular orientation of event.
74972 120 CHI=PARU(2)*PYR(0)
74973 CTHE=2D0*PYR(0)-1D0
74981 C2PHI=COS(2D0*(PHI-PARJ(134)))
74982 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74983 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
74984 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
74985 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
74986 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
74987 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
74988 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
74989 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
74990 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
74993 C...Generate parton shower. Rearrange along strings and check.
74994 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
74995 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
74997 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
74998 IF(MSTJ(105).GE.0) MSTU(28)=0
75001 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
75004 C...Generate fragmentation. Information for PYTABU:
75005 IF(MSTJ(105).EQ.1) CALL PYEXEC
75006 MSTU(161)=110*KFLC+3
75012 C*********************************************************************
75015 C...Books a histogram.
75017 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
75019 C...Double precision declaration.
75020 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75021 IMPLICIT INTEGER(I-N)
75023 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75025 C...Local character variables.
75026 CHARACTER TITLE*(*), TITFX*60
75028 C...Check that input is sensible. Find initial address in memory.
75029 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75030 &'(PYBOOK:) not allowed histogram number')
75031 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
75032 &'(PYBOOK:) not allowed number of bins')
75033 IF(XL.GE.XU) CALL PYERRM(28,
75034 &'(PYBOOK:) x limits in wrong order')
75036 IHIST(4)=IHIST(4)+28+NX
75037 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
75038 &'(PYBOOK:) out of histogram space')
75041 C...Store histogram size and reset contents.
75045 BIN(IS+4)=(XU-XL)/NX
75048 C...Store title by conversion to integer to double precision.
75051 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
75052 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
75058 C*********************************************************************
75061 C...Fills entry in histogram.
75063 SUBROUTINE PYFILL(ID,X,W)
75065 C...Double precision declaration.
75066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75067 IMPLICIT INTEGER(I-N)
75069 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75072 C...Find initial address in memory. Increase number of entries.
75073 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75074 &'(PYFILL:) not allowed histogram number')
75076 IF(IS.EQ.0) CALL PYERRM(28,
75077 &'(PYFILL:) filling unbooked histogram')
75078 BIN(IS+5)=BIN(IS+5)+1D0
75080 C...Find bin in x, including under/overflow, and fill.
75081 IF(X.LT.BIN(IS+2)) THEN
75082 BIN(IS+6)=BIN(IS+6)+W
75083 ELSEIF(X.GE.BIN(IS+3)) THEN
75084 BIN(IS+8)=BIN(IS+8)+W
75086 BIN(IS+7)=BIN(IS+7)+W
75087 IX=(X-BIN(IS+2))/BIN(IS+4)
75088 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
75089 BIN(IS+9+IX)=BIN(IS+9+IX)+W
75095 C*********************************************************************
75098 C...Multiplies histogram contents by factor.
75100 SUBROUTINE PYFACT(ID,F)
75102 C...Double precision declaration.
75103 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75104 IMPLICIT INTEGER(I-N)
75106 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75109 C...Find initial address in memory. Multiply all contents bins.
75110 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75111 &'(PYFACT:) not allowed histogram number')
75113 IF(IS.EQ.0) CALL PYERRM(28,
75114 &'(PYFACT:) scaling unbooked histogram')
75115 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
75122 C*********************************************************************
75125 C...Performs operations between histograms.
75127 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
75129 C...Double precision declaration.
75130 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75131 IMPLICIT INTEGER(I-N)
75133 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75135 C...Character variable.
75138 C...Find initial addresses in memory, and histogram size.
75139 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
75140 &'(PYFACT:) not allowed histogram number')
75142 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
75143 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
75144 NX=NINT(BIN(IS3+1))
75145 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
75147 C...Update info on number of histogram entries.
75148 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
75149 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
75150 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
75151 BIN(IS3+5)=BIN(IS1+5)
75154 C...Operations on pair of histograms: addition, subtraction,
75155 C...multiplication, division.
75156 IF(OPER.EQ.'+') THEN
75158 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
75160 ELSEIF(OPER.EQ.'-') THEN
75162 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
75164 ELSEIF(OPER.EQ.'*') THEN
75166 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
75168 ELSEIF(OPER.EQ.'/') THEN
75171 IF(ABS(FA2).LE.1D-20) THEN
75174 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
75178 C...Operations on single histogram: multiplication+addition,
75179 C...square root+addition, logarithm+addition.
75180 ELSEIF(OPER.EQ.'A') THEN
75182 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
75184 ELSEIF(OPER.EQ.'S') THEN
75186 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
75188 ELSEIF(OPER.EQ.'L') THEN
75191 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
75192 & ZMIN=0.8D0*BIN(IS1+IX)
75195 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
75198 C...Operation on two or three histograms: average and
75199 C...standard deviation.
75200 ELSEIF(OPER.EQ.'M') THEN
75202 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75205 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
75208 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75211 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
75215 BIN(IS1+IX)=F1*BIN(IS1+IX)
75222 C*********************************************************************
75225 C...Prints and resets all histograms.
75229 C...Double precision declaration.
75230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75231 IMPLICIT INTEGER(I-N)
75233 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75236 C...Loop over histograms, print and reset used ones.
75237 DO 100 ID=1,IHIST(1)
75239 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
75248 C*********************************************************************
75251 C...Prints a histogram (but does not reset it).
75253 SUBROUTINE PYPLOT(ID)
75255 C...Double precision declaration.
75256 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75257 IMPLICIT INTEGER(I-N)
75259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75260 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75261 SAVE /PYDAT1/,/PYBINS/
75262 C...Local arrays and character variables.
75263 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
75264 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
75266 C...Steps in histogram scale. Character sequence.
75267 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
75268 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
75270 C...Find initial address in memory; skip if empty histogram.
75271 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75274 IF(NINT(BIN(IS+5)).LE.0) THEN
75275 WRITE(MSTU(11),5000) ID
75279 C...Number of histogram lines and x bins.
75283 C...Extract title by conversion from double precision via integer.
75285 IEQ=NINT(BIN(IS+8+NX+IT))
75286 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
75287 & //CHAR(MOD(IEQ,256))
75290 C...Find time; print title.
75292 IF(IDATI(1).GT.0) THEN
75293 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
75295 WRITE(MSTU(11),5200) ID, TITLE
75298 C...Find minimum and maximum bin content.
75301 DO 110 IX=IS+10,IS+8+NX
75302 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
75303 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
75306 C...Determine scale and step size for y axis.
75307 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
75308 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
75309 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
75310 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
75311 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
75312 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
75315 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
75319 C...Convert bin contents to integer form; fractional fill in top row.
75321 CTA=ABS(BIN(IS+8+IX))/DY
75322 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
75323 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
75325 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
75326 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
75328 C...Print histogram row by row.
75329 DO 150 IR=IRMA,IRMI,-1
75330 IF(IR.EQ.0) GOTO 150
75333 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
75334 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
75336 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
75339 C...Print sign and value of bin contents.
75340 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
75343 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
75344 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
75346 WRITE(MSTU(11),5400) OUT
75349 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75351 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
75354 C...Print sign and value of lower bin edge.
75355 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
75359 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
75360 & OUT(IX:IX)=CHA(11)
75361 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
75363 WRITE(MSTU(11),5600) OUT
75366 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75368 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
75372 C...Calculate and print statistics.
75377 CTA=ABS(BIN(IS+8+IX))
75378 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
75381 CXXSUM=CXXSUM+CTA*X**2
75383 XMEAN=CXSUM/MAX(CSUM,1D-20)
75384 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
75385 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
75386 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
75388 C...Formats for output.
75389 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
75390 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
75392 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
75393 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
75394 5400 FORMAT(/8X,'Contents',3X,A100)
75395 5500 FORMAT(9X,'*10**',I2,3X,A100)
75396 5600 FORMAT(/8X,'Low edge',3X,A100)
75397 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
75398 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
75399 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
75404 C*********************************************************************
75407 C...Resets bin contents of a histogram.
75409 SUBROUTINE PYNULL(ID)
75411 C...Double precision declaration.
75412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75413 IMPLICIT INTEGER(I-N)
75415 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75418 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75421 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
75428 C*********************************************************************
75431 C...Dumps histogram contents on file for reading by other program.
75432 C...Can also read back own dump.
75434 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
75436 C...Double precision declaration.
75437 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75438 IMPLICIT INTEGER(I-N)
75440 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75442 C...Local arrays and character variables.
75443 DIMENSION IHI(*),ISS(100),VAL(5)
75444 CHARACTER TITLE*60,FORMAT*13
75446 C...Dump all histograms that have been booked,
75447 C...including titles and ranges, one after the other.
75448 IF(MDUMP.EQ.1) THEN
75450 C...Loop over histograms and find which are wanted and booked.
75465 C...Write title, histogram size, filling statistics.
75468 IEQ=NINT(BIN(IS+8+NX+IT))
75469 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
75470 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
75472 WRITE(LFN,5100) ID,TITLE
75473 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
75474 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
75478 C...Write histogram contents, in groups of five.
75479 DO 120 IXG=1,(NX+4)/5
75483 VAL(IXV)=BIN(IS+8+IX)
75488 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
75491 C...Go to next histogram; finish.
75492 ELSEIF(NHI.GT.0) THEN
75493 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75497 C...Read back in histograms dumped MDUMP=1.
75498 ELSEIF(MDUMP.EQ.2) THEN
75500 C...Read histogram number, title and range, and book.
75501 140 READ(LFN,5100,END=170) ID,TITLE
75502 READ(LFN,5200) NX,XL,XU
75503 CALL PYBOOK(ID,TITLE,NX,XL,XU)
75506 C...Read filling statistics.
75507 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
75508 BIN(IS+5)=DBLE(NENTRY)
75510 C...Read histogram contents, in groups of five.
75511 DO 160 IXG=1,(NX+4)/5
75512 READ(LFN,5400) (VAL(IXV),IXV=1,5)
75515 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
75519 C...Go to next histogram; finish.
75523 C...Write histogram contents in column format,
75524 C...convenient e.g. for GNUPLOT input.
75525 ELSEIF(MDUMP.EQ.3) THEN
75527 C...Find addresses to wanted histograms.
75541 IF(IS.NE.0.AND.NSS.LT.100) THEN
75544 ELSEIF(NSS.GE.100) THEN
75545 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
75546 ELSEIF(NHI.GT.0) THEN
75547 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75551 C...Check that they have common number of x bins. Fix format.
75552 NX=NINT(BIN(ISS(1)+1))
75554 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
75555 CALL PYERRM(8,'(PYDUMP:) different number of bins')
75559 FORMAT='(1P,000E12.4)'
75560 WRITE(FORMAT(5:7),'(I3)') NSS+1
75562 C...Write histogram contents; first column x values.
75564 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
75565 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
75570 C...Formats for output.
75571 5100 FORMAT(I5,5X,A60)
75572 5200 FORMAT(I5,1P,2D12.4)
75573 5300 FORMAT(I12,1P,3D12.4)
75574 5400 FORMAT(1P,5D12.4)
75579 C*********************************************************************
75582 C...Allows users to handle STOP statemens
75584 SUBROUTINE PYSTOP(MCOD)
75586 C...Double precision and integer declarations.
75587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75588 IMPLICIT INTEGER(I-N)
75589 INTEGER PYK,PYCHGE,PYCOMP
75591 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75595 C...Write message, then stop
75596 WRITE(MSTU(11),5000) MCOD
75600 C...Formats for output.
75601 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
75605 C*********************************************************************
75608 C...Dummy routine, which the user can replace in order to make cuts on
75609 C...the kinematics on the parton level before the matrix elements are
75610 C...evaluated and the event is generated. The cross-section estimates
75611 C...will automatically take these cuts into account, so the given
75612 C...values are for the allowed phase space region only. MCUT=0 means
75613 C...that the event has passed the cuts, MCUT=1 that it has failed.
75615 SUBROUTINE PYKCUT(MCUT)
75617 C...Double precision and integer declarations.
75618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75619 IMPLICIT INTEGER(I-N)
75620 INTEGER PYK,PYCHGE,PYCOMP
75622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75623 COMMON/PYINT1/MINT(400),VINT(400)
75624 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75625 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75627 C...Set default value (accepting event) for MCUT.
75630 C...Read out subprocess number.
75634 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75638 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75640 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75642 C...Calculate x_1, x_2, x_F.
75643 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
75644 X1=SQRT(TAU)*EXP(YST)
75645 X2=SQRT(TAU)*EXP(-YST)
75647 X1=SQRT(TAUP)*EXP(YST)
75648 X2=SQRT(TAUP)*EXP(-YST)
75652 C...Calculate shat, that, uhat, p_T^2.
75658 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
75659 RPTS=4D0*VINT(71)**2/SHAT
75660 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
75663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
75664 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
75665 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
75666 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
75668 C...Decisions by user to be put here.
75670 C...Stop program if this routine is ever called.
75671 C...You should not copy these lines to your own routine.
75672 WRITE(MSTU(11),5000)
75675 C...Format for error printout.
75676 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
75677 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75678 &1X,'Execution stopped!')
75683 C*********************************************************************
75686 C...Dummy routine, which the user can replace in order to multiply the
75687 C...standard PYTHIA differential cross-section by a process- and
75688 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
75689 C...to generation of weighted events, with weight 1/WTXS, while for
75690 C...MSTP(142)=2 it corresponds to a modification of the underlying
75693 SUBROUTINE PYEVWT(WTXS)
75695 C...Double precision and integer declarations.
75696 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75697 IMPLICIT INTEGER(I-N)
75698 INTEGER PYK,PYCHGE,PYCOMP
75700 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75701 COMMON/PYINT1/MINT(400),VINT(400)
75702 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75703 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75705 C...Set default weight for WTXS.
75708 C...Read out subprocess number.
75712 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75716 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75718 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75720 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
75729 C...Modifications by user to be put here.
75731 C...Stop program if this routine is ever called.
75732 C...You should not copy these lines to your own routine.
75733 WRITE(MSTU(11),5000)
75736 C...Format for error printout.
75737 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
75738 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75739 &1X,'Execution stopped!')
75744 C*********************************************************************
75747 C...Dummy routine, to be replaced by a user implementing external
75748 C...processes. Is supposed to fill the HEPRUP commonblock with info
75749 C...on incoming beams and allowed processes.
75751 C...New example: handles a standard Les Houches Events File.
75755 C...Double precision and integer declarations.
75756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75757 IMPLICIT INTEGER(I-N)
75759 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
75760 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75763 C...User process initialization commonblock.
75765 PARAMETER (MAXPUP=100)
75766 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75767 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75768 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75769 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75773 C...Lines to read in assumed never longer than 200 characters.
75774 PARAMETER (MAXLEN=200)
75775 CHARACTER*(MAXLEN) STRING
75777 C...Format for reading lines.
75780 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75782 C...Loop until finds line beginning with "<init>" or "<init ".
75783 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
75786 C...Allow indentation.
75787 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
75788 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
75789 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
75791 C...Read first line of initialization info.
75792 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
75793 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75795 C...Read NPRUP subsequent lines with information on each process.
75797 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
75798 & XMAXUP(IPR),LPRUP(IPR)
75802 C...Error exit: give up if initalization does not work.
75803 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
75804 WRITE(*,*) ' Event generation will be stopped.'
75810 C...Old example: handles a simple Pythia 6.4 initialization file.
75812 c SUBROUTINE UPINIT
75814 C...Double precision and integer declarations.
75815 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75816 c IMPLICIT INTEGER(I-N)
75819 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75820 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75821 c SAVE /PYDAT1/,/PYPARS/
75823 C...User process initialization commonblock.
75825 c PARAMETER (MAXPUP=100)
75826 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75827 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75828 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75829 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75833 C...Read info from file.
75834 c IF(MSTP(161).GT.0) THEN
75835 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
75836 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75837 c DO 100 IPR=1,NPRUP
75838 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
75839 c & XMAXUP(IPR),LPRUP(IPR)
75842 C...Error or prematurely reached end of file.
75843 c 110 WRITE(MSTU(11),5000)
75846 C...Else not implemented.
75848 c WRITE(MSTU(11),5100)
75852 C...Format for error printout.
75853 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
75854 c &1X,'Execution stopped!')
75855 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
75856 c &1X,'Dummy routine in PYTHIA file called instead.'/
75857 c &1X,'Execution stopped!')
75862 C*********************************************************************
75865 C...Dummy routine, to be replaced by a user implementing external
75866 C...processes. Depending on cross section model chosen, it either has
75867 C...to generate a process of the type IDPRUP requested, or pick a type
75868 C...itself and generate this event. The event is to be stored in the
75869 C...HEPEUP commonblock, including (often) an event weight.
75871 C...New example: handles a standard Les Houches Events File.
75875 C...Double precision and integer declarations.
75876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75877 IMPLICIT INTEGER(I-N)
75879 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
75880 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75883 C...User process event common block.
75885 PARAMETER (MAXNUP=500)
75886 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75887 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75888 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75889 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75890 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75893 C...Lines to read in assumed never longer than 200 characters.
75894 PARAMETER (MAXLEN=200)
75895 CHARACTER*(MAXLEN) STRING
75897 C...Format for reading lines.
75900 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75902 C...Loop until finds line beginning with "<event>" or "<event ".
75903 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
75906 C...Allow indentation.
75907 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
75908 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
75909 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
75911 C...Read first line of event info.
75912 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
75915 C...Read NUP subsequent lines with information on each particle.
75917 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
75918 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75919 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75923 C...Error exit, typically when no more events.
75924 130 WRITE(*,*) ' Failed to read LHEF event information.'
75925 WRITE(*,*) ' Will assume end of file has been reached.'
75932 C...Old example: handles a simple Pythia 6.4 event file.
75934 c SUBROUTINE UPEVNT
75936 C...Double precision and integer declarations.
75937 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75938 c IMPLICIT INTEGER(I-N)
75941 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75942 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75943 c SAVE /PYDAT1/,/PYPARS/
75945 C...User process event common block.
75947 c PARAMETER (MAXNUP=500)
75948 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75949 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75950 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75951 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75952 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75955 C...Read info from file.
75956 c IF(MSTP(162).GT.0) THEN
75957 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
75960 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
75961 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75962 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75965 C...Special when reached end of file or other error.
75968 C...Else not implemented.
75970 c WRITE(MSTU(11),5000)
75974 C...Format for error printout.
75975 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
75976 c &1X,'Dummy routine in PYTHIA file called instead.'/
75977 c &1X,'Execution stopped!')
75982 C*********************************************************************
75985 C...Dummy routine, to be replaced by user, to veto event generation
75986 C...on the parton level, after parton showers but before multiple
75987 C...interactions, beam remnants and hadronization is added.
75988 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
75989 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
75990 C...be undecayed at this stage; if decayed their decay products will
75991 C...have been allowed to shower.
75993 C...All partons at the end of the shower phase are stored in the
75994 C...HEPEVT commonblock. The interesting information is
75995 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
75996 C...IDHEP(I) = the particle ID code according to PDG conventions,
75997 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
75998 C...All ISTHEP entries are 1, while the rest is zeroed.
76000 C...The user decision is to be conveyed by the IVETO value.
76001 C...IVETO = 0 : retain current event and generate in full;
76002 C... = 1 : abort generation of current event and move to next.
76004 SUBROUTINE UPVETO(IVETO)
76006 C...HEPEVT commonblock.
76007 PARAMETER (NMXHEP=4000)
76008 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
76009 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
76010 DOUBLE PRECISION PHEP,VHEP
76013 C...Next few lines allow you to see what info PYVETO extracted from
76014 C...the full event record for the first two events.
76015 C...Delete if you don't want it.
76018 IF(NLIST.LE.2) THEN
76019 WRITE(*,*) ' Full event record at time of UPVETO call:'
76021 WRITE(*,*) ' Part of event record made available to UPVETO:'
76026 C...Make decision here.
76032 C*********************************************************************
76034 C*********************************************************************
76037 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
76039 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
76040 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76041 IMPLICIT INTEGER(I-N)
76042 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
76045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76048 C...Stop program if this routine is ever called.
76049 WRITE(MSTU(11),5000)
76052 C...Format for error printout.
76053 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76054 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
76055 &1X,'Execution stopped!')
76060 C*********************************************************************
76063 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76067 IMPLICIT INTEGER(I-N)
76068 CHARACTER*40 VISAJE
76071 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76074 C...Assign default value.
76077 C...Stop program if this routine is ever called.
76078 WRITE(MSTU(11),5000)
76081 C...Format for error printout.
76082 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76083 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
76084 &1X,'Execution stopped!')
76089 C*********************************************************************
76092 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76094 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
76095 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
76096 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
76098 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76099 IMPLICIT INTEGER(I-N)
76100 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
76101 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
76102 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
76104 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76107 C...Stop program if this routine is ever called.
76108 WRITE(MSTU(11),5000)
76111 C...Format for error printout.
76112 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76113 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
76114 &1X,'Execution stopped!')
76118 C*********************************************************************
76121 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76123 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
76124 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76125 IMPLICIT INTEGER(I-N)
76126 Cmssmpart = 4 # full MSSM [recommended]
76127 Cfieldren = 0 # MSbar field ren. [strongly recommended]
76128 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
76129 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
76130 Cp2approx = 0 # no approximation [recommended]
76131 Clooplevel= 2 # include 2-loop corrections
76132 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
76133 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
76136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76139 C...Stop program if this routine is ever called.
76140 WRITE(MSTU(11),5000)
76143 C...Format for error printout.
76144 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76145 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
76146 &1X,'Execution stopped!')
76150 C*********************************************************************
76153 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76155 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
76156 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
76157 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
76158 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
76159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76160 IMPLICIT INTEGER(I-N)
76162 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76163 DOUBLE COMPLEX DMU,
76164 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76168 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76171 C...Stop program if this routine is ever called.
76172 WRITE(MSTU(11),5000)
76175 C...Format for error printout.
76176 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76177 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76178 &1X,'Execution stopped!')
76182 C*********************************************************************
76185 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76187 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
76188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76189 IMPLICIT INTEGER(I-N)
76191 C...FeynHiggs variables
76192 DOUBLE PRECISION RMHIGG(4)
76193 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76194 DOUBLE COMPLEX DMU,
76195 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76199 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76202 C...Stop program if this routine is ever called.
76203 WRITE(MSTU(11),5000)
76206 C...Format for error printout.
76207 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76208 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76209 &1X,'Execution stopped!')
76213 C*********************************************************************
76216 C...Dummy routine, to be replaced by user, to handle the decay of a
76217 C...polarized tau lepton.
76219 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
76220 C...IORIG is the position where the mother of the tau is stored;
76221 C... is 0 when the mother is not stored.
76222 C...KFORIG is the flavour of the mother of the tau;
76223 C... is 0 when the mother is not known.
76224 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
76225 C... e.g. in B hadron semileptonic decays the W propagator
76226 C... is not explicitly stored but the W code is still unambiguous.
76228 C...NDECAY is the number of decay products in the current tau decay.
76229 C...These decay products should be added to the /PYJETS/ common block,
76230 C...in positions N+1 through N+NDECAY. For each product I you must
76231 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
76232 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
76234 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
76236 C...Double precision and integer declarations.
76237 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76238 IMPLICIT INTEGER(I-N)
76239 INTEGER PYK,PYCHGE,PYCOMP
76241 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76243 SAVE /PYJETS/,/PYDAT1/
76245 C...Stop program if this routine is ever called.
76246 C...You should not copy these lines to your own routine.
76247 NDECAY=ITAU+IORIG+KFORIG
76248 WRITE(MSTU(11),5000)
76251 C...Format for error printout.
76252 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
76253 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
76254 &1X,'Execution stopped!')
76259 C*********************************************************************
76262 C...Finds current date and time.
76263 C...Since this task is not standardized in Fortran 77, the routine
76264 C...is dummy, to be replaced by the user. Examples are given for
76265 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
76266 C...you do not have access to suitable routines.
76268 SUBROUTINE PYTIME(IDATI)
76270 C...Double precision and integer declarations.
76271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76272 IMPLICIT INTEGER(I-N)
76273 INTEGER PYK,PYCHGE,PYCOMP
76276 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
76278 C...Example 0: if you do not have suitable routines.
76283 C...Example 1: Fortran 90 routine.
76284 C CALL DATE_AND_TIME(VALUES=IVAL)
76292 C...Example 2: DEC Fortran 77. AIX.
76293 C CALL IDATE(IMON,IDAY,IYEAR)
76297 C CALL ITIME(IHOUR,IMIN,ISEC)
76302 C...Example 3: DEC Fortran, IRIX, IRIX64.
76303 C CALL IDATE(IMON,IDAY,IYEAR)
76311 C READ(ATIME(1:2),'(I2)') IHOUR
76312 C READ(ATIME(4:5),'(I2)') IMIN
76313 C READ(ATIME(7:8),'(I2)') ISEC
76318 C...Example 4: GNU LINUX libU77, SunOS.
76319 C CALL IDATE(IDTEMP)
76320 C IDATI(1)=IDTEMP(3)
76321 C IDATI(2)=IDTEMP(2)
76322 C IDATI(3)=IDTEMP(1)
76323 C CALL ITIME(IDTEMP)
76324 C IDATI(4)=IDTEMP(1)
76325 C IDATI(5)=IDTEMP(2)
76326 C IDATI(6)=IDTEMP(3)
76328 C...Common code to ensure right century.
76329 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob